summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/JSON/PP.pm
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/JSON/PP.pm')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/JSON/PP.pm398
1 files changed, 197 insertions, 201 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/JSON/PP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/JSON/PP.pm
index 2475fe1e87..fc8fcbc8f0 100644
--- a/systems/texlive/tlnet/tlpkg/tlperl/lib/JSON/PP.pm
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/JSON/PP.pm
@@ -2,21 +2,22 @@ package JSON::PP;
# JSON-2.0
-use 5.005;
+use 5.008;
use strict;
use Exporter ();
-BEGIN { @JSON::PP::ISA = ('Exporter') }
+BEGIN { our @ISA = ('Exporter') }
use overload ();
use JSON::PP::Boolean;
use Carp ();
+use Scalar::Util qw(blessed reftype refaddr);
#use Devel::Peek;
-$JSON::PP::VERSION = '4.06';
+our $VERSION = '4.16';
-@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
+our @EXPORT = qw(encode_json decode_json from_json to_json);
# instead of hash-access, i tried index-access for speed.
# but this method is not faster than what i expected. so it will be changed.
@@ -44,8 +45,19 @@ use constant P_AS_NONBLESSED => 17;
use constant P_ALLOW_UNKNOWN => 18;
use constant P_ALLOW_TAGS => 19;
-use constant OLD_PERL => $] < 5.008 ? 1 : 0;
use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0;
+use constant CORE_BOOL => defined &builtin::is_bool;
+
+my $invalid_char_re;
+
+BEGIN {
+ $invalid_char_re = "[";
+ for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok
+ $invalid_char_re .= quotemeta chr utf8::unicode_to_native($i);
+ }
+
+ $invalid_char_re = qr/$invalid_char_re]/;
+}
BEGIN {
if (USE_B) {
@@ -64,14 +76,6 @@ BEGIN {
allow_barekey escape_slash as_nonblessed
);
- # Perl version check, Unicode handling is enabled?
- # Helper module sets @JSON::PP::_properties.
- if ( OLD_PERL ) {
- my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
- eval qq| require $helper |;
- if ($@) { Carp::croak $@; }
- }
-
for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
my $property_id = 'P_' . uc($name);
@@ -201,13 +205,54 @@ sub boolean_values {
my ($false, $true) = @_;
$self->{false} = $false;
$self->{true} = $true;
+ if (CORE_BOOL) {
+ BEGIN { CORE_BOOL and warnings->unimport(qw(experimental::builtin)) }
+ if (builtin::is_bool($true) && builtin::is_bool($false) && $true && !$false) {
+ $self->{core_bools} = !!1;
+ }
+ else {
+ delete $self->{core_bools};
+ }
+ }
} else {
delete $self->{false};
delete $self->{true};
+ delete $self->{core_bools};
}
return $self;
}
+sub core_bools {
+ my $self = shift;
+ my $core_bools = defined $_[0] ? $_[0] : 1;
+ if ($core_bools) {
+ $self->{true} = !!1;
+ $self->{false} = !!0;
+ $self->{core_bools} = !!1;
+ }
+ else {
+ $self->{true} = $JSON::PP::true;
+ $self->{false} = $JSON::PP::false;
+ $self->{core_bools} = !!0;
+ }
+ return $self;
+}
+
+sub get_core_bools {
+ my $self = shift;
+ return !!$self->{core_bools};
+}
+
+sub unblessed_bool {
+ my $self = shift;
+ return $self->core_bools(@_);
+}
+
+sub get_unblessed_bool {
+ my $self = shift;
+ return $self->get_core_bools(@_);
+}
+
sub get_boolean_values {
my $self = shift;
if (exists $self->{true} and exists $self->{false}) {
@@ -326,14 +371,6 @@ sub allow_bigint {
$str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
- unless ($ascii or $latin1 or $utf8) {
- utf8::upgrade($str);
- }
-
- if ($props->[ P_SHRINK ]) {
- utf8::downgrade($str, 1);
- }
-
return $str;
}
@@ -412,7 +449,6 @@ sub allow_bigint {
my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
for my $k ( _sort( $obj ) ) {
- if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
push @res, $self->string_to_json( $k )
. $del
. ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) );
@@ -476,7 +512,11 @@ sub allow_bigint {
my $type = ref($value);
if (!$type) {
- if (_looks_like_number($value)) {
+ BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
+ if (CORE_BOOL && builtin::is_bool($value)) {
+ return $value ? 'true' : 'false';
+ }
+ elsif (_looks_like_number($value)) {
return $value;
}
return $self->string_to_json($value);
@@ -527,16 +567,18 @@ sub allow_bigint {
sub string_to_json {
my ($self, $arg) = @_;
- $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
+ $arg =~ s/(["\\\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/\//\\\//g if ($escape_slash);
- $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
+
+ # On ASCII platforms, matches [\x00-\x08\x0b\x0e-\x1f]
+ $arg =~ s/([^\n\t\c?[:^cntrl:][:^ascii:]])/'\\u00' . unpack('H2', $1)/eg;
if ($ascii) {
- $arg = JSON_PP_encode_ascii($arg);
+ $arg = _encode_ascii($arg);
}
if ($latin1) {
- $arg = JSON_PP_encode_latin1($arg);
+ $arg = _encode_latin1($arg);
}
if ($utf8) {
@@ -604,7 +646,7 @@ sub allow_bigint {
sub _encode_ascii {
join('',
map {
- $_ <= 127 ?
+ chr($_) =~ /[[:ascii:]]/ ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
@@ -658,11 +700,11 @@ BEGIN {
{ # PARSE
my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
- b => "\x8",
- t => "\x9",
- n => "\xA",
- f => "\xC",
- r => "\xD",
+ b => "\b",
+ t => "\t",
+ n => "\n",
+ f => "\f",
+ r => "\r",
'\\' => '\\',
'"' => '"',
'/' => '/',
@@ -736,7 +778,6 @@ BEGIN {
}
}
else {
- utf8::upgrade( $text );
utf8::encode( $text );
}
@@ -845,7 +886,7 @@ BEGIN {
decode_error("missing high surrogate character in surrogate pair");
}
$is_utf8 = 1;
- $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
+ $s .= _decode_surrogates($utf16, $u) || next;
$utf16 = undef;
}
else {
@@ -853,9 +894,10 @@ BEGIN {
decode_error("surrogate pair expected");
}
- if ( ( my $hex = hex( $u ) ) > 127 ) {
+ my $hex = hex( $u );
+ if ( chr $u =~ /[[:^ascii:]]/ ) {
$is_utf8 = 1;
- $s .= JSON_PP_decode_unicode($u) || next;
+ $s .= _decode_unicode($u) || next;
}
else {
$s .= chr $hex;
@@ -873,7 +915,7 @@ BEGIN {
}
else{
- if ( ord $ch > 127 ) {
+ if ( $ch =~ /[[:^ascii:]]/ ) {
unless( $ch = is_valid_utf8($ch) ) {
$at -= 1;
decode_error("malformed UTF-8 character in JSON string");
@@ -886,10 +928,12 @@ BEGIN {
}
if (!$loose) {
- if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
+ if ($ch =~ $invalid_char_re) { # '/' ok
if (!$relaxed or $ch ne "\t") {
$at--;
- decode_error('invalid character encountered while parsing JSON string');
+ decode_error(sprintf "invalid character 0x%X"
+ . " encountered while parsing JSON string",
+ ord $ch);
}
}
}
@@ -1102,7 +1146,7 @@ BEGIN {
sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
my $key;
- while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
+ while($ch =~ /[\$\w[:^ascii:]]/){
$key .= $ch;
next_chr();
}
@@ -1235,31 +1279,55 @@ BEGIN {
return $is_dec ? $v/1.0 : 0+$v;
}
+ # Compute how many bytes are in the longest legal official Unicode
+ # character
+ my $max_unicode_length = do {
+ no warnings 'utf8';
+ chr 0x10FFFF;
+ };
+ utf8::encode($max_unicode_length);
+ $max_unicode_length = length $max_unicode_length;
sub is_valid_utf8 {
- $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
- : $_[0] =~ /[\xC2-\xDF]/ ? 2
- : $_[0] =~ /[\xE0-\xEF]/ ? 3
- : $_[0] =~ /[\xF0-\xF4]/ ? 4
- : 0
- ;
-
- return unless $utf8_len;
-
- my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
-
- return ( $is_valid_utf8 =~ /^(?:
- [\x00-\x7F]
- |[\xC2-\xDF][\x80-\xBF]
- |[\xE0][\xA0-\xBF][\x80-\xBF]
- |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
- |[\xED][\x80-\x9F][\x80-\xBF]
- |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
- |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
- |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
- |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
- )$/x ) ? $is_valid_utf8 : '';
+ # Returns undef (setting $utf8_len to 0) unless the next bytes in $text
+ # comprise a well-formed UTF-8 encoded character, in which case,
+ # return those bytes, setting $utf8_len to their count.
+
+ my $start_point = substr($text, $at - 1);
+
+ # Look no further than the maximum number of bytes in a single
+ # character
+ my $limit = $max_unicode_length;
+ $limit = length($start_point) if $limit > length($start_point);
+
+ # Find the number of bytes comprising the first character in $text
+ # (without having to know the details of its internal representation).
+ # This loop will iterate just once on well-formed input.
+ while ($limit > 0) { # Until we succeed or exhaust the input
+ my $copy = substr($start_point, 0, $limit);
+
+ # decode() will return true if all bytes are valid; false
+ # if any aren't.
+ if (utf8::decode($copy)) {
+
+ # Is valid: get the first character, convert back to bytes,
+ # and return those bytes.
+ $copy = substr($copy, 0, 1);
+ utf8::encode($copy);
+ $utf8_len = length $copy;
+ return substr($start_point, 0, $utf8_len);
+ }
+
+ # If it didn't work, it could be that there is a full legal character
+ # followed by a partial or malformed one. Narrow the window and
+ # try again.
+ $limit--;
+ }
+
+ # Failed to find a legal UTF-8 character.
+ $utf8_len = 0;
+ return;
}
@@ -1270,22 +1338,15 @@ BEGIN {
my $mess = '';
my $type = 'U*';
- if ( OLD_PERL ) {
- my $type = $] < 5.006 ? 'C*'
- : utf8::is_utf8( $str ) ? 'U*' # 5.6
- : 'C*'
- ;
- }
-
for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
- $mess .= $c == 0x07 ? '\a'
- : $c == 0x09 ? '\t'
- : $c == 0x0a ? '\n'
- : $c == 0x0d ? '\r'
- : $c == 0x0c ? '\f'
- : $c < 0x20 ? sprintf('\x{%x}', $c)
- : $c == 0x5c ? '\\\\'
- : $c < 0x80 ? chr($c)
+ my $chr_c = chr($c);
+ $mess .= $chr_c eq '\\' ? '\\\\'
+ : $chr_c =~ /[[:print:]]/ ? $chr_c
+ : $chr_c eq '\a' ? '\a'
+ : $chr_c eq '\t' ? '\t'
+ : $chr_c eq '\n' ? '\n'
+ : $chr_c eq '\r' ? '\r'
+ : $chr_c eq '\f' ? '\f'
: sprintf('\x{%x}', $c)
;
if ( length $mess >= 20 ) {
@@ -1364,136 +1425,54 @@ sub _decode_unicode {
return $un;
}
-#
-# Setup for various Perl versions (the code from JSON::PP58)
-#
-
-BEGIN {
-
- unless ( defined &utf8::is_utf8 ) {
- require Encode;
- *utf8::is_utf8 = *Encode::is_utf8;
- }
-
- if ( !OLD_PERL ) {
- *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
- *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
- *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
- *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
-
- if ($] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
- package JSON::PP;
- require subs;
- subs->import('join');
- eval q|
- sub join {
- return '' if (@_ < 2);
- my $j = shift;
- my $str = shift;
- for (@_) { $str .= $j . $_; }
- return $str;
- }
- |;
- }
- }
+sub incr_parse {
+ local $Carp::CarpLevel = 1;
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
+}
- sub JSON::PP::incr_parse {
- local $Carp::CarpLevel = 1;
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
- }
+sub incr_skip {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
+}
- sub JSON::PP::incr_skip {
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
- }
+sub incr_reset {
+ ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
+}
+sub incr_text : lvalue {
+ $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
- sub JSON::PP::incr_reset {
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
+ if ( $_[0]->{_incr_parser}->{incr_pos} ) {
+ Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
-
- eval q{
- sub JSON::PP::incr_text : lvalue {
- $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
-
- if ( $_[0]->{_incr_parser}->{incr_pos} ) {
- Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
- }
- $_[0]->{_incr_parser}->{incr_text};
- }
- } if ( $] >= 5.006 );
-
-} # Setup for various Perl versions (the code from JSON::PP58)
+ $_[0]->{_incr_parser}->{incr_text};
+}
###############################
# Utilities
#
-BEGIN {
- eval 'require Scalar::Util';
- unless($@){
- *JSON::PP::blessed = \&Scalar::Util::blessed;
- *JSON::PP::reftype = \&Scalar::Util::reftype;
- *JSON::PP::refaddr = \&Scalar::Util::refaddr;
- }
- else{ # This code is from Scalar::Util.
- # warn $@;
- eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
- *JSON::PP::blessed = sub {
- local($@, $SIG{__DIE__}, $SIG{__WARN__});
- ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
- };
- require B;
- my %tmap = qw(
- B::NULL SCALAR
- B::HV HASH
- B::AV ARRAY
- B::CV CODE
- B::IO IO
- B::GV GLOB
- B::REGEXP REGEXP
- );
- *JSON::PP::reftype = sub {
- my $r = shift;
-
- return undef unless length(ref($r));
-
- my $t = ref(B::svref_2object($r));
-
- return
- exists $tmap{$t} ? $tmap{$t}
- : length(ref($$r)) ? 'REF'
- : 'SCALAR';
- };
- *JSON::PP::refaddr = sub {
- return undef unless length(ref($_[0]));
-
- my $addr;
- if(defined(my $pkg = blessed($_[0]))) {
- $addr .= bless $_[0], 'Scalar::Util::Fake';
- bless $_[0], $pkg;
- }
- else {
- $addr .= $_[0]
- }
-
- $addr =~ /0x(\w+)/;
- local $^W;
- #no warnings 'portable';
- hex($1);
- }
- }
-}
-
-
# shamelessly copied and modified from JSON::XS code.
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
-sub is_bool { blessed $_[0] and ( $_[0]->isa("JSON::PP::Boolean") or $_[0]->isa("Types::Serialiser::BooleanBase") or $_[0]->isa("JSON::XS::Boolean") ); }
+sub is_bool {
+ if (blessed $_[0]) {
+ return (
+ $_[0]->isa("JSON::PP::Boolean")
+ or $_[0]->isa("Types::Serialiser::BooleanBase")
+ or $_[0]->isa("JSON::XS::Boolean")
+ );
+ }
+ elsif (CORE_BOOL) {
+ BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
+ return builtin::is_bool($_[0]);
+ }
+ return !!0;
+}
sub true { $JSON::PP::true }
sub false { $JSON::PP::false }
@@ -1514,7 +1493,7 @@ use constant INCR_M_C1 => 5;
use constant INCR_M_TFN => 6;
use constant INCR_M_NUM => 7;
-$JSON::PP::IncrParser::VERSION = '1.01';
+our $VERSION = '1.01';
sub new {
my ( $class ) = @_;
@@ -1534,10 +1513,6 @@ sub incr_parse {
$self->{incr_text} = '' unless ( defined $self->{incr_text} );
if ( defined $text ) {
- if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
- utf8::upgrade( $self->{incr_text} ) ;
- utf8::decode( $self->{incr_text} ) ;
- }
$self->{incr_text} .= $text;
}
@@ -1563,6 +1538,10 @@ sub incr_parse {
}
}
+ unless ( $coder->get_utf8 ) {
+ utf8::decode( $self->{incr_text} );
+ }
+
my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
push @ret, $obj;
use bytes;
@@ -1600,7 +1579,7 @@ INCR_PARSE:
while ( $len > $p ) {
$s = substr( $text, $p, 1 );
last INCR_PARSE unless defined $s;
- if ( ord($s) > 0x20 ) {
+ if ( ord($s) > ord " " ) {
if ( $s eq '#' ) {
$self->{incr_mode} = INCR_M_C0;
redo INCR_PARSE;
@@ -1627,6 +1606,7 @@ INCR_PARSE:
}
next;
} elsif ( $mode == INCR_M_TFN ) {
+ last INCR_PARSE if $p >= $len && $self->{incr_nest};
while ( $len > $p ) {
$s = substr( $text, $p++, 1 );
next if defined $s and $s =~ /[rueals]/;
@@ -1638,6 +1618,7 @@ INCR_PARSE:
last INCR_PARSE unless $self->{incr_nest};
redo INCR_PARSE;
} elsif ( $mode == INCR_M_NUM ) {
+ last INCR_PARSE if $p >= $len && $self->{incr_nest};
while ( $len > $p ) {
$s = substr( $text, $p++, 1 );
next if defined $s and $s =~ /[0-9eE.+\-]/;
@@ -1674,7 +1655,7 @@ INCR_PARSE:
if ( $s eq "\x00" ) {
$p--;
last INCR_PARSE;
- } elsif ( $s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) {
+ } elsif ( $s =~ /^[\t\n\r ]$/) {
if ( !$self->{incr_nest} ) {
$p--; # do not eat the whitespace, let the next round do it
last INCR_PARSE;
@@ -1770,10 +1751,6 @@ JSON::PP - JSON::XS compatible pure-Perl module.
use JSON;
-=head1 VERSION
-
- 4.05
-
=head1 DESCRIPTION
JSON::PP is a pure perl JSON decoder/encoder, and (almost) compatible to much
@@ -1833,6 +1810,9 @@ Returns true if the passed scalar represents either JSON::PP::true or
JSON::PP::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.
+On perl 5.36 and above, will also return true when given one of perl's
+standard boolean values, such as the result of a comparison.
+
See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.
@@ -2249,6 +2229,22 @@ to their default values.
C<get_boolean_values> will return both C<$false> and C<$true> values, or
the empty list when they are set to the default.
+=head2 core_bools
+
+ $json->core_bools([$enable]);
+
+If C<$enable> is true (or missing), then C<decode>, will produce standard
+perl boolean values. Equivalent to calling:
+
+ $json->boolean_values(!!1, !!0)
+
+C<get_core_bools> will return true if this has been set. On perl 5.36, it will
+also return true if the boolean values have been set to perl's core booleans
+using the C<boolean_values> method.
+
+The methods C<unblessed_bool> and C<get_unblessed_bool> are provided as aliases
+for compatibility with L<Cpanel::JSON::XS>.
+
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])