view release on metacpan or  search on metacpan

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

    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 = "<undef>"
    }
    defined wantarray ? $label.$val : warn($label.$val."\n");
}

push( @EXPORT, 'pv' );

# Processing JSON.

my $_json_xs;
my $_json_rr;
our $json_last;

sub json_load( $json, $source = "<builtin>" ) {

    # We have two JSON parsers: Relaxed and XS.
    # Relaxed accepts a lot of relaxing extensions, but XS is much
    # much faster. So fast, in fact, that trying XS first will be a
    # win in many cases, and a neglectable overhead in the other
    # cases.

    state $jx = JSON::XS->new;
    $jx->relaxed;

    # Glue lines, so we have at lease some relaxation.
    $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.