view release on metacpan or  search on metacpan

lib/ChordPro/Utils.pm  view on Meta::CPAN

    $json =~ s/"\s*\\\r?\n\s*"//g;

    my $data;
    $json_last = "xs";
    eval { $data = $jx->decode($json."\n"); $_json_xs++ };
    return $data if defined $data;

    require JSON::Relaxed;
    state $jr = JSON::Relaxed::Parser->new( croak_on_error => 0,
					    strict => 0,
					    prp => 1 );
    $_json_rr++;
    $json_last = "rr";
    $data = $jr->decode($json."\n");
    return $data unless $jr->is_error;
    $source .= ": " if $source;
    die("${source}JSON error: " . $jr->err_msg . "\n");
}

sub json_stats( $reset = 0 ) {
    my $res = { xs => $_json_xs//0, rr => $_json_rr//0 };
    if ( $reset ) {
	$_json_xs = $_json_rr = 0;
    }
    return $res;
}

push( @EXPORT, qw(json_load json_stats) );

# Like prp2cfg, but updates.
# Also allows array pre/append and JSON data.
# Useful error messages are signalled with exceptions.

push( @EXPORT, 'prpadd2cfg' );

sub prpadd2cfg ( $cfg, @defs ) {
    $cfg //= {};
    state $specials = { false => 0, true => 1, null => undef };

    while ( @defs ) {
	my $key   = shift(@defs);
	my $value = shift(@defs);
	# warn("K:$key V:$value\n");

	# Check and process the value, if needed.
	if ( exists $specials->{$value} ) {
	    $value = $specials->{$value};
	    # warn("Value => $value\n");
	}
	elsif ( !( ref($value)
		   || $value !~ /[\[\{\]\}]/ ) ) {
	    # Not simple, assume JSON struct.
	    $value = json_load( $value, $value );
	    # use DDP; p($value, as => "Value ->");
	}

	# Note that ':' is not oficially supported by RRJson.
	my @keys = split( /[:.]/, $key );
	my $lastkey = pop(@keys);

	# Handle pdf.fonts.xxx shortcuts.
	if ( join( ".", @keys ) eq "pdf.fonts" ) {
	    my $s = { pdf => { fonts => { $lastkey => $value } } };
	    ChordPro::Config::expand_font_shortcuts($s);
	    $value = $s->{pdf}{fonts}{$lastkey};
	}

	my $cur = \$cfg;		# current pointer in struct
	my $errkey = "";		# error trail
	if ( $keys[0] eq "chords" ) {
	    # Chords are not in the config, but elsewhere.
	    $cur = \ChordPro::Chords::config_chords();
	    $errkey = "chords.";
	    shift(@keys);
	}

	# Step through the keys.
	foreach ( @keys ) {
	    if ( is_arrayref($$cur) ) {
		my $ok;
		if ( /^[<>]?[-+]?\d+$/ ) {
		    $cur = \($$cur->[$_]);
		    $ok++;
		}
		elsif ( ! exists( $$cur->[0]->{name} ) ) {
		    die("Array ", substr($errkey,0,-1),
			" requires integer index (got \"$_\")\n");
		}
		else {
		    for my $i ( 0..@{$$cur} ) {
			if ( $$cur->[$i]->{name} eq $_ ) {
			    $cur = \($$cur->[$i]);
			    $ok++;
			    last;
			}
		    }
		}
		unless ( $ok ) {
		    die("Array ", substr($errkey,0,-1),
				" has no matching element with name \"$_\"\n");
		}
	    }
	    elsif ( is_hashref($$cur) ) {
		$cur = \($$cur->{$_});
	    }
	    else {
		die("Key ", substr($errkey,0,-1),
		    " ", ref($$cur),
		    " does not refer to an array or hash\n");
	    }
	    $errkey .= "$_."

	}

	# Final key.
	if ( is_arrayref($$cur) ) {
	    if ( $lastkey =~ />([-+]?\d+)?$/ ) {	# append
		if ( defined $1 ) {
		    splice( @{$$cur},
			    $1 >= 0 ? 1+$1 : 1+@{$$cur}+$1, 0, $value );
		}
		else {
		    push( @{$$cur}, $value );
		}
	    }

lib/ChordPro/Utils.pm  view on Meta::CPAN

						      %$value } );
	    }
	    else {
		$$cur->{$lastkey} = $value;
	    }
	}
	else {
	    die("Key ", substr($errkey,0,-1),
		" is scalar, not ",
		$lastkey =~ /^(?:[-+]?\d+|[<>])$/ ? "array" : "hash",
		"\n");
	}
    }

    # The structure has been modified, but also return for covenience.
    return $cfg;
}

push( @EXPORT, 'prpadd2cfg' );

# Remove markup.
sub demarkup ( $t ) {
    return join( '', grep { ! /^\</ } splitmarkup($t) );
}
push( @EXPORT, 'demarkup' );

# Split into markup/nonmarkup segments.
sub splitmarkup ( $t ) {
    my @t = split( qr;(</?(?:[-\w]+|span\s.*?)>);, $t );
    return @t;
}
push( @EXPORT, 'splitmarkup' );

# For conditional filling of hashes.
sub maybe ( $key, $value, @rest ) {
    if (defined $key and defined $value) {
	return ( $key, $value, @rest );
    }
    else {
	( defined($key) || @rest ) ? @rest : ();
    }
}
push( @EXPORT, "maybe" );

# Min/Max.
use List::Util ();
*min = \&List::Util::min;
*max = \&List::Util::max;

push( @EXPORT, "min", "max" );

# Plural
sub plural( $n, $tag, $plural=undef ) {
    $plural //= $tag . "s";
    ( $n || "no" ) . ( $n == 1 ? $tag : $plural );
}

push( @EXPORT, "plural" );

# Dimensions.
# Fontsize allows typical font units, and defaults to ref 12.
sub fontsize( $size, $ref=12 ) {
    if ( $size && $size =~ /^([.\d]+)(%|e[mx]|p[tx])$/ ) {
	return $ref/100 * $1 if $2 eq '%';
	return $ref     * $1 if $2 eq 'em';
	return $ref/2   * $1 if $2 eq 'ex';
	return $1            if $2 eq 'pt';
	return $1 * 0.75     if $2 eq 'px';
    }
    $size || $ref;
}

push( @EXPORT, "fontsize" );

# Dimension allows arbitrary units, and defaults to ref 12.
sub dimension( $size, %sz ) {
    return unless defined $size;
    my $ref;
    if ( ( $ref = $sz{fsize} )
	 && $size =~ /^([.\d]+)(%|e[mx])$/ ) {
	return $ref/100 * $1  if $2 eq '%';
	return $ref     * $1  if $2 eq 'em';
	return $ref/2   * $1  if $2 eq 'ex';
    }
    if ( ( $ref = $sz{width} )
	 && $size =~ /^([.\d]+)(%)$/ ) {
	return $ref/100 * $1  if $2 eq '%';
    }
    if ( $size =~ /^([.\d]+)(p[tx]|[cm]m|in|)$/ ) {
	return $1             if $2 eq 'pt';
	return $1 * 0.75      if $2 eq 'px';
	return $1 * 72 / 2.54 if $2 eq 'cm';
	return $1 * 72 / 25.4 if $2 eq 'mm';
	return $1 * 72        if $2 eq 'in';
	return $1             if $2 eq '';
    }
    $size;			# let someone else croak
}

push( @EXPORT, "dimension" );

# Checking font names against the PDF corefonts.

my %corefonts =
  (
   ( map { lc($_) => $_ }
     "Times-Roman",
     "Times-Bold",
     "Times-Italic",
     "Times-BoldItalic",
     "Helvetica",
     "Helvetica-Bold",
     "Helvetica-Oblique",
     "Helvetica-BoldOblique",
     "Courier",
     "Courier-Bold",
     "Courier-Oblique",
     "Courier-BoldOblique",
     "Symbol",
     "ZapfDingbats" ),
);

sub is_corefont {
    $corefonts{lc $_[0]};
}

push( @EXPORT, "is_corefont" );

# Progress reporting.

use Ref::Util qw(is_coderef);

# Progress can return a false result to allow caller to stop.

sub progress(%args) {
    state $callback;
    state $phase = "";
    state $index = 0;
    state $total = '';
    unless ( %args ) {		# reset
	undef $callback;
	$phase = "";
	$index = 0;
	return;
    }

    $callback = $args{callback} if exists $args{callback};
    return 1 unless $callback;

    if ( exists $args{phase} ) {
	$index = 0 if $phase ne $args{phase};
	$phase = $args{phase};
    }
    if ( exists $args{index} ) {
	$index = $args{index};

	# Use index<0 to only set callback/phase.
	$index = 0, $total = '', return if $index < 0;
    }
    if ( exists $args{total} ) {
	$total = $args{total};
    }

    my $args = { phase => $phase, index => $index, total => $total, %args };

    my $ret = ++$index;
    if ( is_coderef($callback) ) {
	$ret = eval { $callback->(%$args) };
	if ( $@ ) {
	    warn($@);
	    undef $callback;
	}
    }
    else {
	if ( $callback eq "warn" ) {
	    # Simple progress message. Suppress if $index = 0 or total = 1.
	    $callback =
	      '%{index=0||' .
	      '%{total=1||Progress[%{phase}]: %{index}%{total|/%{}}%{msg| - %{}}}' .
	      '}';
	}
	my $msg = ChordPro::Output::Common::fmt_subst
	  ( { meta => $args }, $callback );
	$msg =~ s/\n+$//;
	warn( $msg, "\n" ) if $msg;
    }