App-Music-ChordPro
view release on metacpan or search on metacpan
lib/ChordPro/lib/JSON/Relaxed/Parser.pm view on Meta::CPAN
$croak_on_error_internal = 0;
$self->_decode($str);
}
method _decode( $str ) {
$data = $str;
return $self->error('missing-input')
unless defined $data && length $data;
undef $err_id;
$err_pos = -1;
undef $err_msg;
$self->pretokenize;
return if $self->is_error;
$self->tokenize;
return $self->error('empty-input') unless @tokens;
$self->structure( top => 1 );
}
################ Character classifiers ################
# Reserved characters.
# '[' beginning of array
# ']' end of array
# '{' beginning of hash
# '}' end of hash
# ':' delimiter between name and value of hash element
# ',' separator between elements in hashes and arrays
my $p_reserved = q<[,:{}\[\]]>;
method is_reserved ($c) {
$c =~ /^$p_reserved$/;
}
# Newlines. CRLF (Windows), CR (MacOS) and newline (sane systems).
my $p_newlines = q{(?:\r\n|\r|\n|\\\n)};
method is_newline ($c) {
$c =~ /^$p_newlines$/o;
}
# Quotes. Single, double and backtick.
my $p_quotes = q{["'`]};
method is_quote ($c) {
$c =~ /^$p_quotes$/o;
}
# Numbers. A special case of unquoted strings.
my $p_number = q{[+-]?\d*\.?\d+(?:[Ee][+-]?\d+)?};
method pretokenize {
# \u escape (4 hexits)
my @p = ( qq<\\\\u[[:xdigit:]]{4}> );
# Any escaped char (strict mode).
if ( $strict ) {
push( @p, qq<\\\\.> );
}
# Otherwise, match \u{ ... } also.
else {
push( @p, qq<\\\\u\\{[[:xdigit:]]+\\}>, qq<\\\\[^u]> ); # escaped char
}
if ( $prp && !$strict ) {
# Add = to the reserved characters
$p_reserved = q<[,=:{}\[\]]>;
# Massage # comments into // comments without affecting position.
$data =~ s/^(\s*)#.(.*)$/$1\/\/$2/gm;
$data =~ s/^(\s*)#$/$1 /gm;
}
push( @p, $p_newlines,
qq< // [^\\n]* \\n >, # line comment
qq< /\\* .*? \\*/ >, # comment start
qq< /\\* >, # comment start
qq< $p_reserved >, # reserved chars
qq< "(?:\\\\.|.)*?" >, # "string"
qq< `(?:\\\\.|.)*?` >, # `string`
qq< '(?:\\\\.|.)*?' >, # 'string'
qq< $p_quotes >, # stringquote
qq< \\s+ > ); # whitespace
my $p = join( "|", @p );
# Improve less than 3%
# use Regexp::Assemble;
# my $re = Regexp::Assemble->new;
# for ( @p ) {
# s/ //g;
# }
# $re->add($_) for @p;
# my $p = $re->re;
# Improve less than 1%
# $p =~ s/ //g;
# @pretoks = split( m<($p)>so, $data );
@pretoks = split( m< ( $p ) >sox, $data );
# Remove empty strings.
@pretoks = grep { length($_) } @pretoks;
return;
}
# Accessor for @pretoks.
method pretoks() { \@pretoks }
method tokenize {
@tokens = ();
my $offset = 0; # token offset in input
if ( $booleans ) {
if ( ref($booleans) ne 'ARRAY' ) {
$booleans = [ $JSON::Boolean::false, $JSON::Boolean::true ];
}
}
else {
$booleans = [ 0, 1 ];
}
my $glue = 0; # can glue strings
lib/ChordPro/lib/JSON/Relaxed/Parser.pm view on Meta::CPAN
# content, do nothing with it in strict mode. Ignore otherwise.
if ( $t eq ',' && (!$strict || @$rv) ) {
}
# Opening brace of hash or array.
elsif ( $this->is_list_opener ) {
unshift( @tokens, $this );
my $object = $self->structure;
defined($object) or return undef;
push( @$rv, $object );
}
# if string, add it to the array
elsif ( $this->is_string ) {
# add the string to the array
push( @$rv, $this->as_perl );
# Check following token.
if ( @tokens ) {
my $next = $tokens[0] || '';
# Spec say: Commas are optional between objects pairs
# and array items.
# The next element must be a comma or the closing brace,
# or a string or list.
# Anything else is an error.
unless ( $next->token =~ /^[,\]]$/
|| $next->is_string
|| $next->is_list_opener ) {
return $self->error( 'missing_comma-between-array-elements',
$next );
}
}
}
# Else unkown object or character, so throw error.
else {
return $self->error( 'unknown-array-token', $this );
}
}
# If we get this far then unclosed brace.
return $self->error('unclosed-array-brace');
}
method is_comment_opener( $pretok ) {
$pretok eq '//' || $pretok eq '/*';
}
use List::Util qw( min max uniqstr );
method encode(%opts) {
my $schema = $opts{schema};
my $level = $opts{level} // 0;
my $rv = $opts{data}; # allow undef
my $indent = $opts{indent} // 2;
my $impoh = $opts{implied_outer_hash} // $implied_outer_hash;
my $ckeys = $opts{combined_keys} // $combined_keys;
my $prpmode = $opts{prp} // $prp;
my $pretty = $opts{pretty} // $pretty;
my $strict = $opts{strict} // $strict;
my $nouesc = $opts{nounicodeescapes} // 0;
if ( $strict ) {
$ckeys = $prpmode = $impoh = 0;
}
$schema = resolve( $schema, $schema ) if $schema;
my $s = "";
my $i = 0;
my $props = $schema->{properties};
#warn("L$level - ", join(" ", sort keys(%$props)),"\n");
# Add comments from schema, if any.
my $comments = sub( $p ) {
my $s = "";
my $did = 0;#$level;
for my $topic ( qw( title description ) ) {
next unless $p->{$topic};
$s .= "\n" unless $did++;
$s .= (" " x $i) . "// $_\n"
for split( /\s*<br\/?>|\\n|\n/, $p->{$topic} );
}
return $s;
};
if ( !$level ) {
$s .= $comments->($schema);
}
# Format a string value.
my $pr_string = sub ( $str, $force = 0 ) {
# Reserved strings.
if ( !defined($str) ) {
return "null";
}
if ( UNIVERSAL::isa( $str, 'JSON::Boolean' )
|| UNIVERSAL::isa( $str, 'JSON::PP::Boolean' ) ) {
return (qw(false true))[$str]; # force string result
}
my $v = $str;
# Escapes.
$v =~ s/\\/\\\\/g;
$v =~ s/\n/\\n/g;
$v =~ s/\r/\\r/g;
$v =~ s/\f/\\f/g;
$v =~ s/\013/\\v/g;
$v =~ s/\010/\\b/g;
$v =~ s/\t/\\t/g;
$v =~ s/([^ -ÿ])/sprintf( ord($1) < 0xffff ? "\\u%04x" : "\\u{%x}", ord($1))/ge unless $nouesc;
# Force quotes unless the string can be represented as unquoted.
if ( # contains escapes
$v ne $str
# not value-formed numeric
|| ( $v =~ /^$p_number$/ && 0+$v ne $v )
# contains reserved, quotes or spaces
|| $v =~ $p_reserved
|| $v =~ $p_quotes
|| $v =~ /\s/
|| $v =~ /^(true|false|null)$/
|| !length($v)
) {
if ( $v !~ /\"/ ) {
return '"' . $v . '"';
}
if ( $v !~ /\'/ ) {
return "'" . $v . "'";
}
if ( $v !~ /\`/ ) {
return "`" . $v . "`";
}
return '"' . ($v =~ s/(["'`])/\\$1/rg) . '"';
}
# Just a string.
return $v;
};
# Format an array value.
my $pr_array = sub ( $rv, $level=0, $props = {} ) {
return "[]" unless @$rv;
# Gather list of formatted values.
my @v = map { $self->encode( %opts,
data => $_,
level => $level+1,
schema => $props,
) } @$rv;
return "[".join(",",@v)."]" unless $pretty;
# If sufficiently short, put it on one line.
if ( $i + length("@v") < 72
&& join("",@v) !~ /\s|$p_newlines/ ) {
return "[ @v ]";
}
# Put the values on separate lines.
my $s = "[\n";
$s .= s/^/(" " x ($i+$indent))/gemr . "\n" for @v;
$s .= (" " x $i) . "]";
return $s;
};
# Format a hash value.
my $pr_hash; $pr_hash = sub ( $rv, $level=0, $props = {} ) {
return "{}" unless keys(%$rv);
my $s = "";
# Opening brace.
if ( $level || !$impoh ) {
$s .= $pretty ? "{\n" : "{";
$i += $indent;
}
# If we have a key order, use this and delete.
my @ko = $rv->{" key order "}
? @{ delete($rv->{" key order "}) }
: sort(keys(%$rv));
# Dedup.
@ko = uniqstr(@ko);
my $ll = 0;
for ( @ko ) {
# This may be wrong if \ escapes or combined keys are involved.
$ll = length($_) if length($_) > $ll;
}
for ( @ko ) {
my $k = $_;
# Gather comments, if available.
my $comment;
if ( $props->{$k} ) {
$comment = $comments->($props->{$k});
$s .= $comment if $comment;
}
my $v = $rv->{$k};
my $key = $k; # final key
# Combine keys if allowed and possible.
while ( $ckeys && ref($v) eq 'HASH' && keys(%$v) == 1 ) {
my $k = (keys(%$v))[0];
$key .= ".$k"; # append to final key
$v = $v->{$k}; # step to next
}
$s .= (" " x $i) if $pretty;
# Format the key, try to align on length. NEEDS WORK
my $t = $pr_string->($key);
my $l = length($t);
$s .= $t;
my $in = $comment ? "" : " " x max( 0, $ll-length($t) );
# Handle object serialisation.
my $r = UNIVERSAL::can( $v, "TO_JSON" ) // UNIVERSAL::can( $v, "FREEZE" );
$r = $r ? $v->$r : $v;
# Format the value.
if ( ref($r) eq 'HASH' ) {
# Make up and recurse.
if ( $pretty ) {
$s .= $prpmode ? " " : " : ";
}
elsif ( !$prpmode ) {
$s .= ":";
}
$s .= $pr_hash->( $r, $level+1, $props->{$k}->{properties} );
}
elsif ( ref($r) eq 'ARRAY' ) {
$s .= $pretty ? "$in : " : ":";
$s .= $pr_array->( $r, $level+1, $props->{$k}->{items} );
}
elsif ( $pretty ) {
my $t = $pr_string->($r);
$s .= "$in : ";
# Break quoted strings that contain pseudo-newlines.
if ( $t =~ /^["'`].*\\n/ ) {
# Remove the quotes/
my $quote = substr( $t, 0, 1, '');
lib/ChordPro/lib/JSON/Relaxed/Parser.pm view on Meta::CPAN
$res;
}
=begin heavily_optimized_alternative
package JSON::Relaxed::XXToken;
our @ISA = qw(JSON::Relaxed::Parser);
sub new {
my ( $pkg, %opts ) = @_;
my $self = bless [] => $pkg;
push( @$self,
delete(%opts{parent}),
delete(%opts{token}),
delete(%opts{type}),
delete(%opts{offset}),
);
$self;
}
sub parent { $_[0]->[0] }
sub token { $_[0]->[1] }
sub type { $_[0]->[2] }
sub offset { $_[0]->[3] }
sub is_string { $_[0]->[2] =~ /[QUN]/ }
sub is_list_opener { $_[0]->[2] eq 'C' && $_[0]->[1] =~ /[{\[]/ }
sub as_perl { # for values
return shift->[1]->as_perl(@_);
}
sub _data_printer { # for DDP
my ( $self, $ddp ) = @_;
my $res = "Token(";
if ( $self->is_string ) {
$res .= $self->[1]->_data_printer($ddp);
}
else {
$res .= "\"".$self->[1]."\"";
}
$res .= ", " . $self->[2];
$res . ", " . $self->[3] . ")";
}
sub as_string { # for messages
if ( $_[0]->is_string ) {
return '"' . ($_[0]->[1]->content =~ s/"/\\"/gr) . '"';
}
"\"" . $_[0]->[1] . "\"";
}
=cut
################ Strings ################
class JSON::Relaxed::String :isa(JSON::Relaxed::Token);
field $content :param = undef;
field $quote :accessor :param = undef;
# Quoted strings are assembled from complete substrings, so escape
# processing is done on the substrings. This prevents ugly things
# when unicode escapes are split across substrings.
# Unquotes strings are collected token by token, so escape processing
# can only be done on the complete string (on output).
ADJUST {
$content = $self->unescape($content) if defined($quote);
};
method append ($str) {
$str = $self->unescape($str) if defined $quote;
$content .= $str;
}
method content {
defined($quote) ? $content : $self->unescape($content);
}
# One regexp to match them all...
my $esc_quoted = qr/
\\([tnrfb]) # $1 : one char
| \\u\{([[:xdigit:]]+)\} # $2 : \u{XX...}
| \\u([Dd][89abAB][[:xdigit:]]{2}) # $3 : \uDXXX hi
\\u([Dd][c-fC-F][[:xdigit:]]{2}) # $4 : \uDXXX lo
| \\u([[:xdigit:]]{4}) # $5 : \uXXXX
| \\?(.) # $6
/xs;
# Special escapes (quoted strings only).
my %esc = (
'b' => "\b", # Backspace
'f' => "\f", # Form feed
'n' => "\n", # New line
'r' => "\r", # Carriage return
't' => "\t", # Tab
'v' => chr(11), # Vertical tab
);
method unescape ($str) {
return $str unless $str =~ /\\/;
my $convert = sub {
# Specials. Only for quoted strings.
if ( defined($1) ) {
return defined($quote) ? $esc{$1} : $1;
}
# Extended \u{XXX} character.
defined($2) and return chr(hex($2));
# Pair of surrogates.
defined($3) and return pack( 'U*',
0x10000 + (hex($3) - 0xD800) * 0x400
+ (hex($4) - 0xDC00) );
# Standard \uXXXX character.
defined($5) and return chr(hex($5));
# Anything else.
defined($6) and return $6;
return '';
};
while( $str =~ s/\G$esc_quoted/$convert->()/gxse) {
last unless defined pos($str);
}
return $str;
}
################ Quoted Strings ################
class JSON::Relaxed::String::Quoted :isa(JSON::Relaxed::String);
method as_perl( %options ) {
$self->content;
}
method _data_printer( $ddp ) {
"Token(" . $self->quote . $self->content . $self->quote . ", " .
$self->type . ", " . $self->offset . ")";
}
################ Unquoted Strings ################
class JSON::Relaxed::String::Unquoted :isa(JSON::Relaxed::String);
# If the option always_string is set, bypass the reserved strings.
# This is used for hash keys.
method as_perl( %options ) {
my $content = $self->content;
# If used as a key, always return a string.
return $content if $options{always_string};
# Return boolean specials if appropriate.
if ( $content =~ /^(?:true|false)$/ ) {
return $self->parent->booleans->[ $content eq 'true' ? 1 : 0 ];
( run in 2.449 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )