view release on metacpan or  search on metacpan

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

lib/ChordPro/lib/JSON/Relaxed/Parser.pm  view on Meta::CPAN

=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 '';