File Coverage

lib/ChordPro/Utils.pm

Criterion	Covered	Total	%
statement	232	401	57.8
branch	67	206	32.5
condition	15	49	30.6
subroutine	36	45	80.0
pod	0	28	0.0
total	350	729	48.0

#! perl

package ChordPro::Utils;

use v5.26;
use utf8;
use Carp;
use feature qw( signatures );
no warnings "experimental::signatures";
use Ref::Util qw( is_arrayref is_hashref );

use Exporter 'import';
our @EXPORT;
our @EXPORT_OK;

use ChordPro::Files;

################ Filenames ################

use File::Glob ( ":bsd_glob" );

# Derived from Path::ExpandTilde.

use constant BSD_GLOB_FLAGS => GLOB_NOCHECK | GLOB_QUOTE | GLOB_TILDE | GLOB_ERR
  # add GLOB_NOCASE as in File::Glob
  | ($^O =~ m/\A(?:MSWin32|VMS|os2|dos|riscos)\z/ ? GLOB_NOCASE : 0);

# File::Glob did not try %USERPROFILE% (set in Windows NT derivatives) for ~ before 5.16
use constant WINDOWS_USERPROFILE => is_msw && $] < 5.016;

sub expand_tilde ( $dir ) {

    return undef unless defined $dir;
    return fn_canonpath($dir) unless $dir =~ m/^~/;

    # Parse path into segments.
    my ( $volume, $directories, $file ) = fn_splitpath( $dir, 1 );
    my @parts = fn_splitdir($directories);
    my $first = shift( @parts );
    return fn_canonpath($dir) unless defined $first;

    # Expand first segment.
    my $expanded;
    if ( WINDOWS_USERPROFILE and $first eq '~' ) {
	$expanded = $ENV{HOME} || $ENV{USERPROFILE};
    }
    else {
	( my $pattern = $first ) =~ s/([\\*?{[])/\\$1/g;
	($expanded) = bsd_glob( $pattern, BSD_GLOB_FLAGS );
	croak( "Failed to expand $first: $!") if GLOB_ERROR;
    }
    return fn_canonpath($dir)
      if !defined $expanded or $expanded eq $first;

    # Replace first segment with new path.
    ( $volume, $directories ) = fn_splitpath( $expanded, 1 );
    $directories = fn_catdir( $directories, @parts );
    return fn_catpath($volume, $directories, $file);
}

push( @EXPORT, 'expand_tilde' );

sub sys ( @cmd ) {
    warn("+ @cmd\n") if $::options->{trace};
    # Use outer defined subroutine, depends on Wx or not.
    my $res = ::sys(@cmd);
    warn( sprintf("=%02x=> @cmd", $res), "\n" ) if $res;
    return $res;
}

push( @EXPORT, 'sys' );

################ (Pre)Processing ################

sub make_preprocessor ( $prp ) {
    return unless $prp;

    my $prep;
    foreach my $linetype ( keys %{ $prp } ) {
	my @targets;
	my $code = "";
	foreach ( @{ $prp->{$linetype} } ) {
	    my $flags = $_->{flags} // "g";
	    $code .= "m\0" . $_->{select} . "\0 && "
	      if $_->{select};
	    if ( $_->{pattern} ) {
		$code .= "s\0" . $_->{pattern} . "\0"
		  . $_->{replace} . "\0$flags;\n";
	    }
	    else {
		$code .= "s\0" . quotemeta($_->{target}) . "\0"
		  . quotemeta($_->{replace}) . "\0$flags;\n";
	    }
	}
	if ( $code ) {
	    my $t = "sub { for (\$_[0]) {\n" . $code . "}}";
	    $prep->{$linetype} = eval $t;
	    die( "CODE : $t\n$@" ) if $@;
	}
    }
    $prep;
}

push( @EXPORT, 'make_preprocessor' );

################ Utilities ################

# Split (pseudo) command line into key/value pairs.

# Similar to JavaScript, we do not distinguish single- and double
# quoted strings.
# \\ \' \" yield \ ' " (JS)
# \n yields a newline (convenience)
# Everything else yields the character following the backslash (JS)

my %esc = ( n => "\n", '\\' => '\\', '"' => '"', "'" => "'" );

sub parse_kv ( $line, $kdef = undef ) {

    my @words;
    if ( is_arrayref($line) ) {
	@words = @$line;
    }
    else {
	# Strip.
	$line =~ s/^\s+//;
	$line =~ s/\s+$//;

	# If it doesn't look like key=value, use the default key (if any).
	if ( $kdef && $line !~ /^\w+=(?:['"]|[-+]?\d|\w)/ ) {
	    return { $kdef => $line };
	}

	use Text::ParseWords qw(quotewords);
	@words = quotewords( '\s+', 1, $line );
    }

    my $res = {};
    foreach ( @words ) {

	# Quoted values.
	if ( /^(.*?)=(["'])(.*)\2$/ ) {
	    my ( $k, $v ) = ( $1, $3 );
	    $res->{$k} = $v =~ s;\\(.);$esc{$1}//$1;segr;
	}

	# Unquoted values.
	elsif ( /^(.*?)=(.+)$/ ) {
	    $res->{$1} = $2;
	}

	# Negated keywords.
	elsif ( /^no[-_]?(.+)/ ) {
	    $res->{$1} = 0;
	}

	# Standalone keywords.
	else {
	    $res->{$_}++;
	}
    }

    return $res;
}

push( @EXPORT, 'parse_kv' );

# Split (pseudo) command lines into key/value pairs.

#### LEGACY -- WILL BE REMOVED ####

sub parse_kvm ( @lines ) {

    if ( is_macos() ) {
	# MacOS has the nasty habit to smartify quotes.
	@lines = map { s/“/"/g; s/”/"/g; s/‘/'/g; s/’/'/gr;} @lines;
    }

    use Text::ParseWords qw(quotewords);
    my @words = quotewords( '\s+', 1, @lines );
    parse_kv( \@words );
}

push( @EXPORT, 'parse_kvm' );

# Odd/even.

sub is_odd( $arg ) {
    ( $arg % 2 ) != 0;
}
sub is_even( $arg ) {
    ( $arg % 2 ) == 0;
}

push( @EXPORT, qw( is_odd is_even ) );

# Map true/false etc to true / false.

sub is_true ( $arg ) {
    return 0 if !defined($arg) || $arg eq '';
    return 0 if $arg =~ /^(false|null|no|none|off|\s+|0)$/i;
    return !!$arg;
}

push( @EXPORT, 'is_true' );

# Stricter form of true.
sub is_ttrue ( $arg ) {
    return 0 if !defined($arg);
    $arg =~ /^(on|true|1)$/i;
}

push( @EXPORT, 'is_ttrue' );

# Fix apos -> quote.

sub fq ( $arg ) {
    $arg =~ s/'/\x{2019}/g;
    $arg;
}

push( @EXPORT, 'fq' );

# Quote a string if needed unless forced.

sub qquote ( $arg, $force = 0 ) {
    for ( $arg ) {
	s/([\\\"])/\\$1/g;
	s/([[:^print:]])/sprintf("\\u%04x", ord($1))/ge;
	return $_ unless /[\\\s]/ || $force;
	return qq("$_");
    }
}

push( @EXPORT, 'qquote' );

# Safely print values.

use Scalar::Util qw(looks_like_number);

# We want overload:
# sub pv( $val )
# sub pv( $label, $val )

sub pv {
    my $val   = pop;
    my $label = pop // "";

    my $suppressundef;
    if ( $label =~ /\?$/ ) {
	$suppressundef++;
	$label = $';
    }
    if ( defined $val ) {
	if ( looks_like_number($val) ) {
	    $val = sprintf("%.3f", $val);
	    $val =~ s/0+$//;
	    $val =~ s/\.$//;
	}
	else {
	    $val = qquote( $val, 1 );
	}
    }
    else {
	return "" if $suppressundef;
	$val = ""
    }
    defined wantarray ? $label.$val : warn($label.$val."\n");
}

push( @EXPORT, 'pv' );

# Processing JSON.

sub json_load( $json, $source = "" ) {
    my $info = json_parser();
    if ( $info->{parser} eq "JSON::Relaxed" ) {
	state $pp = JSON::Relaxed::Parser->new( croak_on_error => 0,
						strict => 0,
						prp => 1 );
	my $data = $pp->decode($json."\n");
	return $data unless $pp->is_error;
	$source .= ": " if $source;
	die("${source}JSON error: " . $pp->err_msg . "\n");
    }
    else {
	state $pp = JSON::PP->new;

	# Glue lines, so we have at lease some relaxation.
	$json =~ s/"\s*\\\n\s*"//g;

	$pp->relaxed if $info->{relaxed};
	$pp->decode($json."\n");
    }
}

# JSON parser, what and how (also used by runtimeinfo().
sub json_parser() {
    my $relax = $ENV{CHORDPRO_JSON_RELAXED} // 2;
    if ( $relax > 1 ) {
	require JSON::Relaxed;
	return { parser  => "JSON::Relaxed",
		 version => $JSON::Relaxed::VERSION }
    }
    else {
	require JSON::PP;
	return { parser  => "JSON::PP",
		 relaxed => $relax,
		 version => $JSON::PP::VERSION }
    }
}

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

# 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 );
		}
	    }
	    elsif ( $lastkey =~ /<([-+]?\d+)?$/ ) {	# prepend
		if ( defined $1 ) {
		    splice( @{$$cur}, $1, 0, $value );
		}
		else {
		    unshift( @{$$cur}, $value );
		}
	    }
	    elsif ( $lastkey =~ /\/([-+]?\d+)?$/ ) {	# remove
		if ( defined $1 ) {
		    splice( @{$$cur}, $1, 1 );
		}
		else {
		    pop( @{$$cur} );
		}
	    }
	    else {					# replace
		die("Array $errkey requires integer index (got \"$lastkey\")\n")
		  unless $lastkey =~ /^[-+]?\d+$/;
		$$cur->[$lastkey] = $value;
	    }
	}
	elsif ( is_hashref($$cur) ) {
	    if ( $errkey =~ /^chords\./ ) {
		# Chords must be defined.
		ChordPro::Chords::add_config_chord( { name => $lastkey,
						      %$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 { ! /^\
}
push( @EXPORT, 'demarkup' );

# Split into markup/nonmarkup segments.
sub splitmarkup ( $t ) {
    my @t = split( qr;();, $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;
    }

    return $ret;
}

push( @EXPORT, "progress" );

# Common items for property directives ({textsize} etc.).

sub propitems() {
    qw(  chord chorus diagrams footer grid label tab text title toc );
}

sub propitems_re() {
    my $re = join( '|', propitems() );
    qr/(?:$re)/;
}

push( @EXPORT, "propitems_re" );
push( @EXPORT_OK, "propitems" );

# For debugging encoding problems.

sub as( $s ) {
    return "" unless defined $s;
    $s =~ s{ ( [^\x{20}-\x{7f}] ) }
	   { join( '', map { sprintf '\x{%02x}', ord $_ } split //, $1) }gex;
    return $s;
}

push( @EXPORT_OK, "as" );

sub enumerated( @s ) {
    return "" unless @s;
    my $last = pop(@s);
    my $ret = "";
    $ret .= join(", ", @s) . " and " if @s;
    $ret .= $last;
    return $ret;
}

push( @EXPORT_OK, "enumerated" );

# Determine image type.

sub _detect_image_format( $test ) {

    for ( ref($test) ? $$test : $test ) {
	/^GIF\d\d[a-z]/            and return 'gif';
	/^\xFF\xD8\xFF/            and return 'jpeg';
	/^\x89PNG\x0D\x0A\x1A\x0A/ and return 'png';
	/^\s*P[1-6]/               and return 'pnm';
	/^II\x2A\x00/              and return 'tiff';
	/^MM\x00\x2A/              and return 'tiff';
	/^
    }

    # Not recognized.
    return;
}

sub detect_image_format( $test ) {
    my $format = _detect_image_format($test);

    if ( $format ) {
	return { file_ext => $format, error => "" };
    }
    return { file_ext => "", error => "Unrecognized image type." };
}

push( @EXPORT_OK, "detect_image_format" );

=cut

1;