view release on metacpan or  search on metacpan

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

#! 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;
our %EXPORT_TAGS;

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) ) {

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

    $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 );
		}