summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Changes3
-rw-r--r--MANIFEST2
-rw-r--r--META.json4
-rw-r--r--META.yml2
-rw-r--r--lib/JSON.pm2
-rw-r--r--lib/JSON/backportPP.pm148
-rw-r--r--lib/JSON/backportPP/Boolean.pm2
-rw-r--r--t/01_utf8.t28
-rw-r--r--t/08_pc_base.t2
-rw-r--r--t/108_decode.t12
-rw-r--r--t/109_encode.t36
-rw-r--r--t/112_upgrade.t8
-rw-r--r--t/119_incr_parse_utf8.t5
-rw-r--r--t/120_incr_parse_truncated.t221
-rw-r--r--t/14_latin1.t8
-rw-r--r--t/rt_122270_old_xs_boolean.t33
-rw-r--r--t/xe19_xs_and_suportbypp.t1
17 files changed, 422 insertions, 95 deletions
diff --git a/Changes b/Changes
index 63778d7..3e95c48 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
Revision history for Perl extension JSON.
+4.06 2022-05-22
+ - updated backportPP with JSON::PP 4.09
+
4.05 2022-01-14
- removed VERSION section in pod (GH#52, abraxxa++)
diff --git a/MANIFEST b/MANIFEST
index 79f6318..4eeccc9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -39,6 +39,7 @@ t/117_numbers.t
t/118_boolean_values.t
t/119_incr_parse_utf8.t
t/11_pc_expo.t
+t/120_incr_parse_truncated.t
t/12_blessed.t
t/13_limit.t
t/14_latin1.t
@@ -63,6 +64,7 @@ t/gh_28_json_test_suite.t
t/gh_29_trailing_false_value.t
t/rt_116998_wrong_character_offset.t
t/rt_122270_is_bool_for_obsolete_xs_boolean.t
+t/rt_122270_old_xs_boolean.t
t/rt_90071_incr_parse.t
t/x00_load.t
t/x02_error.t
diff --git a/META.json b/META.json
index fc217bb..f10ff0d 100644
--- a/META.json
+++ b/META.json
@@ -48,6 +48,6 @@
"url" : "https://github.com/makamaka/JSON"
}
},
- "version" : "4.05",
- "x_serialization_backend" : "JSON version 4.05"
+ "version" : "4.06",
+ "x_serialization_backend" : "JSON version 4.06"
}
diff --git a/META.yml b/META.yml
index 93c2cbc..de3da07 100644
--- a/META.yml
+++ b/META.yml
@@ -24,5 +24,5 @@ requires:
resources:
bugtracker: https://github.com/makamaka/JSON/issues
repository: https://github.com/makamaka/JSON
-version: '4.05'
+version: '4.06'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
diff --git a/lib/JSON.pm b/lib/JSON.pm
index 7927301..2c7ed1e 100644
--- a/lib/JSON.pm
+++ b/lib/JSON.pm
@@ -9,7 +9,7 @@ BEGIN { @JSON::ISA = 'Exporter' }
@JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);
BEGIN {
- $JSON::VERSION = '4.05';
+ $JSON::VERSION = '4.06';
$JSON::DEBUG = 0 unless (defined $JSON::DEBUG);
$JSON::DEBUG = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG };
}
diff --git a/lib/JSON/backportPP.pm b/lib/JSON/backportPP.pm
index dfb134e..5abe6f8 100644
--- a/lib/JSON/backportPP.pm
+++ b/lib/JSON/backportPP.pm
@@ -15,7 +15,7 @@ use JSON::backportPP::Boolean;
use Carp ();
#use Devel::Peek;
-$JSON::backportPP::VERSION = '4.07';
+$JSON::backportPP::VERSION = '4.09';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
@@ -48,6 +48,17 @@ 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;
+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) {
require B;
@@ -327,14 +338,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;
}
@@ -528,9 +531,11 @@ 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);
@@ -605,7 +610,7 @@ sub allow_bigint {
sub _encode_ascii {
join('',
map {
- $_ <= 127 ?
+ chr($_) =~ /[[:ascii:]]/ ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
@@ -659,11 +664,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",
'\\' => '\\',
'"' => '"',
'/' => '/',
@@ -737,7 +742,6 @@ BEGIN {
}
}
else {
- utf8::upgrade( $text );
utf8::encode( $text );
}
@@ -854,7 +858,8 @@ 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;
}
@@ -874,7 +879,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");
@@ -887,10 +892,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);
}
}
}
@@ -1103,7 +1110,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();
}
@@ -1236,31 +1243,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 {
+ BEGIN { $] >= 5.006 and require warnings and warnings->unimport('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;
}
@@ -1279,14 +1310,14 @@ BEGIN {
}
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 = $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 ) {
@@ -1537,10 +1568,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;
}
@@ -1567,7 +1594,6 @@ sub incr_parse {
}
unless ( $coder->get_utf8 ) {
- utf8::upgrade( $self->{incr_text} );
utf8::decode( $self->{incr_text} );
}
@@ -1608,7 +1634,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;
@@ -1635,6 +1661,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]/;
@@ -1646,6 +1673,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.+\-]/;
@@ -1682,7 +1710,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;
diff --git a/lib/JSON/backportPP/Boolean.pm b/lib/JSON/backportPP/Boolean.pm
index d6a2d58..15af674 100644
--- a/lib/JSON/backportPP/Boolean.pm
+++ b/lib/JSON/backportPP/Boolean.pm
@@ -11,7 +11,7 @@ overload::import('overload',
fallback => 1,
);
-$JSON::backportPP::Boolean::VERSION = '4.07';
+$JSON::backportPP::Boolean::VERSION = '4.09';
1;
diff --git a/t/01_utf8.t b/t/01_utf8.t
index b05ba66..73c8ded 100644
--- a/t/01_utf8.t
+++ b/t/01_utf8.t
@@ -10,17 +10,23 @@ BEGIN { $ENV{PERL_JSON_BACKEND} ||= "JSON::backportPP"; }
use utf8;
use JSON;
-
-ok (JSON->new->allow_nonref (1)->utf8 (1)->encode ("ü") eq "\"\xc3\xbc\"");
-ok (JSON->new->allow_nonref (1)->encode ("ü") eq "\"ü\"");
-ok (JSON->new->allow_nonref (1)->ascii (1)->utf8 (1)->encode (chr 0x8000) eq '"\u8000"');
-ok (JSON->new->allow_nonref (1)->ascii (1)->utf8 (1)->pretty (1)->encode (chr 0x10402) eq "\"\\ud801\\udc02\"\n");
-
-eval { JSON->new->allow_nonref (1)->utf8 (1)->decode ('"ü"') };
+my $pilcrow_utf8 = (ord "^" == 0x5E) ? "\xc2\xb6" # 8859-1
+ : (ord "^" == 0x5F) ? "\x80\x65" # CP 1024
+ : "\x78\x64"; # assume CP 037
+is (JSON->new->allow_nonref (1)->utf8 (1)->encode ("¶"), "\"$pilcrow_utf8\"");
+is (JSON->new->allow_nonref (1)->encode ("¶"), "\"¶\"");
+is (JSON->new->allow_nonref (1)->ascii (1)->utf8 (1)->encode (chr 0x8000), '"\u8000"');
+is (JSON->new->allow_nonref (1)->ascii (1)->utf8 (1)->pretty (1)->encode (chr 0x10402), "\"\\ud801\\udc02\"\n");
+
+eval { JSON->new->allow_nonref (1)->utf8 (1)->decode ('"¶"') };
ok $@ =~ /malformed UTF-8/;
-ok (JSON->new->allow_nonref (1)->decode ('"ü"') eq "ü");
-ok (JSON->new->allow_nonref (1)->decode ('"\u00fc"') eq "ü");
-ok (JSON->new->allow_nonref (1)->decode ('"\ud801\udc02' . "\x{10204}\"") eq "\x{10402}\x{10204}");
-ok (JSON->new->allow_nonref (1)->decode ('"\"\n\\\\\r\t\f\b"') eq "\"\012\\\015\011\014\010");
+is (JSON->new->allow_nonref (1)->decode ('"¶"'), "¶");
+is (JSON->new->allow_nonref (1)->decode ('"\u00b6"'), "¶");
+is (JSON->new->allow_nonref (1)->decode ('"\ud801\udc02' . "\x{10204}\""), "\x{10402}\x{10204}");
+
+my $controls = (ord "^" == 0x5E) ? "\012\\\015\011\014\010"
+ : (ord "^" == 0x5F) ? "\025\\\015\005\014\026" # CP 1024
+ : "\045\\\015\005\014\026"; # assume CP 037
+is (JSON->new->allow_nonref (1)->decode ('"\"\n\\\\\r\t\f\b"'), "\"$controls");
diff --git a/t/08_pc_base.t b/t/08_pc_base.t
index 1607569..cfcb548 100644
--- a/t/08_pc_base.t
+++ b/t/08_pc_base.t
@@ -77,7 +77,7 @@ $obj = $pc->decode($js);
is($obj->[0],"\x01");
$obj = ["\e"];
-is($js = $pc->encode($obj),'["\\u001b"]');
+is($js = $pc->encode($obj), (ord("A") == 65) ? '["\\u001b"]' : '["\\u0027"]');
$obj = $pc->decode($js);
is($obj->[0],"\e");
diff --git a/t/108_decode.t b/t/108_decode.t
index e38e438..c575a2e 100644
--- a/t/108_decode.t
+++ b/t/108_decode.t
@@ -9,6 +9,8 @@ BEGIN { plan tests => 6 };
BEGIN { $ENV{PERL_JSON_BACKEND} ||= "JSON::backportPP"; }
+my $isASCII = ord "A" == 65;
+
use JSON;
no utf8;
@@ -22,16 +24,20 @@ is($json->decode(q|"\u00c3\u00bc"|), "\xc3\xbc"); # utf8
my $str = 'あ'; # Japanese 'a' in utf8
-is($json->decode(q|"\u00e3\u0081\u0082"|), $str);
+is($json->decode(($isASCII) ? q|"\u00e3\u0081\u0082"|
+ : q|"\u00ce\u0043\u0043"|),
+ $str);
utf8::decode($str); # usually UTF-8 flagged on, but no-op for 5.005.
is($json->decode(q|"\u3042"|), $str);
-my $utf8 = $json->decode(q|"\ud808\udf45"|); # chr 12345
+# chr 0x12400, which was chosen because it has the same representation in
+# both EBCDIC 1047 and 037
+my $utf8 = $json->decode(q|"\ud809\udc00"|);
utf8::encode($utf8); # UTF-8 flagged off
-is($utf8, "\xf0\x92\x8d\x85");
+is($utf8, ($isASCII) ? "\xf0\x92\x90\x80" : "\xDE\x4A\x41\x41");
diff --git a/t/109_encode.t b/t/109_encode.t
index afc5fe3..9f28e0d 100644
--- a/t/109_encode.t
+++ b/t/109_encode.t
@@ -9,20 +9,46 @@ BEGIN { plan tests => 7 };
BEGIN { $ENV{PERL_JSON_BACKEND} ||= "JSON::backportPP"; }
+my $isASCII = ord "A" == 65;
+
use JSON;
no utf8;
my $json = JSON->new->allow_nonref;
-is($json->encode("ü"), q|"ü"|); # as is
+# U+00B6 chosen because it works on both ASCII and EBCDIC
+is($json->encode("¶"), q|"¶"|); # as is
$json->ascii;
-is($json->encode("\xfc"), q|"\u00fc"|); # latin1
-is($json->encode("\xc3\xbc"), q|"\u00c3\u00bc"|); # utf8
-is($json->encode("ü"), q|"\u00c3\u00bc"|); # utf8
-is($json->encode('あ'), q|"\u00e3\u0081\u0082"|);
+if ($] < 5.008) {
+ is($json->encode("\xb6"), q|"\u00b6"|); # latin1
+ is($json->encode("\xc2\xb6"), q|"\u00c2\u00b6"|); # utf8
+ is($json->encode("¶"), q|"\u00c2\u00b6"|); # utf8
+ is($json->encode('あ'), q|"\u00e3\u0081\u0082"|);
+}
+else {
+ is($json->encode("\xb6"), q|"\u00b6"|); # latin1
+
+ if (ord "A" == 65) {
+ is($json->encode("\xc2\xb6"), q|"\u00c2\u00b6"|); # utf8
+ is($json->encode("¶"), q|"\u00c2\u00b6"|); # utf8
+ is($json->encode('あ'), q|"\u00e3\u0081\u0082"|);
+ }
+ else {
+ if (ord '^' == 95) { # EBCDIC 1047
+ is($json->encode("\x80\x65"), q|"\u0080\u0065"|); # utf8
+ is($json->encode("¶"), q|"\u0080\u0065"|); # utf8
+ }
+ else { # Assume EBCDIC 037
+ is($json->encode("\x78\x64"), q|"\u0078\u0064"|); # utf8
+ is($json->encode("¶"), q|"\u0078\u0064"|); # utf8
+ }
+
+ is($json->encode('あ'), (q|"\u00ce\u0043\u0043"|));
+ }
+}
if ($] >= 5.006) {
is($json->encode(chr hex 3042 ), q|"\u3042"|);
diff --git a/t/112_upgrade.t b/t/112_upgrade.t
index 6b9ad89..537d54d 100644
--- a/t/112_upgrade.t
+++ b/t/112_upgrade.t
@@ -9,17 +9,17 @@ BEGIN { $ENV{PERL_JSON_BACKEND} ||= "JSON::backportPP"; }
use JSON;
my $json = JSON->new->allow_nonref->utf8;
-my $str = '\\u00c8';
+my $str = '\\u00b6';
-my $value = $json->decode( '"\\u00c8"' );
+my $value = $json->decode( '"\\u00b6"' );
#use Devel::Peek;
#Dump( $value );
-is( $value, chr 0xc8 );
+is( $value, chr 0xb6 );
ok( utf8::is_utf8( $value ) );
-eval { $json->decode( '"' . chr(0xc8) . '"' ) };
+eval { $json->decode( '"' . chr(0xb6) . '"' ) };
ok( $@ =~ /malformed UTF-8 character in JSON string/ );
diff --git a/t/119_incr_parse_utf8.t b/t/119_incr_parse_utf8.t
index 182a5c6..ed8ef11 100644
--- a/t/119_incr_parse_utf8.t
+++ b/t/119_incr_parse_utf8.t
@@ -1,14 +1,17 @@
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More;
use utf8;
BEGIN { $ENV{PERL_JSON_BACKEND} ||= "JSON::backportPP"; }
use JSON;
+plan skip_all => "not for older version of JSON::PP" if JSON->backend->isa('JSON::PP') && JSON->backend->VERSION < 4.07;
use Encode;
use charnames qw< :full >;
+plan tests => 24;
+
use vars qw< @vs >;
############################################################
diff --git a/t/120_incr_parse_truncated.t b/t/120_incr_parse_truncated.t
new file mode 100644
index 0000000..0eb908e
--- /dev/null
+++ b/t/120_incr_parse_truncated.t
@@ -0,0 +1,221 @@
+use strict;
+use warnings;
+use Test::More;
+BEGIN { $ENV{PERL_JSON_BACKEND} ||= "JSON::backportPP"; }
+
+use JSON;
+plan skip_all => "not for older version of JSON::PP" if JSON->backend->isa('JSON::PP') && JSON->backend->VERSION < 4.09;
+
+plan tests => 19 * 3 + 1 * 6;
+
+sub run_test {
+ my ($input, $sub) = @_;
+ $sub->($input);
+}
+
+run_test('{"one": 1}', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok ($res, "curly braces okay -- '$input'");
+ ok (!$e, "no error -- '$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error");
+});
+
+run_test('{"one": 1]', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "unbalanced curly braces -- '$input'");
+ ok ($e, "got error -- '$input'");
+ like ($e, qr/, or \} expected while parsing object\/hash/, "'} expected' json string error");
+});
+
+run_test('"', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('[', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('}', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok ($e, "no error for input='$input'");
+ like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'");
+});
+
+run_test(']', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok ($e, "no error for input='$input'");
+ like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'");
+});
+
+run_test('1', sub {
+ my $input = shift;
+ my $coder = JSON->new->allow_nonref(1);
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok ($res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'");
+});
+
+run_test('1', sub {
+ my $input = shift;
+ my $coder = JSON->new->allow_nonref(0);
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok ($e, "no error for input='$input'");
+ like ($e, qr/JSON text must be an object or array/, "'JSON text must be an object or array' json string error for input='$input'");
+});
+
+run_test('"1', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'");
+});
+
+run_test('\\', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok ($e, "no error for input='$input'");
+ like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'");
+});
+
+run_test('{"one": "', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{"one": {', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{"one": [', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{"one": t', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{"one": \\', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{"one": ', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{"one": 1', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+});
+
+run_test('{"one": {"two": 2', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated '$input'");
+ ok (!$e, "no error -- '$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error -- $input");
+});
+
+# Test Appending Closing '}' Curly Bracket
+run_test('{"one": 1', sub {
+ my $input = shift;
+ my $coder = JSON->new;
+ my $res = eval { $coder->incr_parse($input) };
+ my $e = $@; # test more clobbers $@, we need it twice
+ ok (!$res, "truncated input='$input'");
+ ok (!$e, "no error for input='$input'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'");
+
+ $res = eval { $coder->incr_parse('}') };
+ $e = $@; # test more clobbers $@, we need it twice
+ ok ($res, "truncated input='$input' . '}'");
+ ok (!$e, "no error for input='$input' . '}'");
+ unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input' . '}'");
+});
diff --git a/t/14_latin1.t b/t/14_latin1.t
index c88cbba..a3d6db0 100644
--- a/t/14_latin1.t
+++ b/t/14_latin1.t
@@ -11,9 +11,9 @@ use JSON;
my $pp = JSON->new->latin1->allow_nonref;
-ok ($pp->encode ("\x{12}\x{89} ") eq "\"\\u0012\x{89} \"");
-ok ($pp->encode ("\x{12}\x{89}\x{abc}") eq "\"\\u0012\x{89}\\u0abc\"");
+ok ($pp->encode ("\x{12}\x{b6} ") eq "\"\\u0012\x{b6} \"");
+ok ($pp->encode ("\x{12}\x{b6}\x{abc}") eq "\"\\u0012\x{b6}\\u0abc\"");
-ok ($pp->decode ("\"\\u0012\x{89}\"" ) eq "\x{12}\x{89}");
-ok ($pp->decode ("\"\\u0012\x{89}\\u0abc\"") eq "\x{12}\x{89}\x{abc}");
+ok ($pp->decode ("\"\\u0012\x{b6}\"" ) eq "\x{12}\x{b6}");
+ok ($pp->decode ("\"\\u0012\x{b6}\\u0abc\"") eq "\x{12}\x{b6}\x{abc}");
diff --git a/t/rt_122270_old_xs_boolean.t b/t/rt_122270_old_xs_boolean.t
new file mode 100644
index 0000000..64fad70
--- /dev/null
+++ b/t/rt_122270_old_xs_boolean.t
@@ -0,0 +1,33 @@
+# copied over from JSON::XS and modified to use JSON
+
+use strict;
+use warnings;
+use Test::More;
+BEGIN { plan tests => 10 };
+
+BEGIN { $ENV{PERL_JSON_BACKEND} ||= "JSON::backportPP"; }
+
+use utf8;
+use JSON;
+
+SKIP: {
+ skip "no JSON::XS < 3", 5 unless eval { require JSON::XS; JSON::XS->VERSION < 3 };
+
+ my $false = JSON::XS::false();
+ ok (JSON::is_bool $false);
+ ok (++$false == 1);
+ ok (!JSON::is_bool $false);
+ ok (!JSON::is_bool "JSON::Boolean");
+ ok (!JSON::is_bool {}); # GH-34
+}
+
+SKIP: {
+ skip "no Types::Serialiser 0.01", 5 unless eval { require JSON::XS; JSON::XS->VERSION(3.00); require Types::Serialiser; Types::Serialiser->VERSION == 0.01 };
+
+ my $false = JSON::XS::false();
+ ok (JSON::is_bool $false);
+ ok (++$false == 1);
+ ok (!JSON::is_bool $false);
+ ok (!JSON::is_bool "JSON::Boolean");
+ ok (!JSON::is_bool {}); # GH-34
+}
diff --git a/t/xe19_xs_and_suportbypp.t b/t/xe19_xs_and_suportbypp.t
index d2467d5..ab84785 100644
--- a/t/xe19_xs_and_suportbypp.t
+++ b/t/xe19_xs_and_suportbypp.t
@@ -13,7 +13,6 @@ SKIP: {
my $json = JSON->new->allow_barekey;
-note explain test($json, q!{foo:"foo"}!);
for (1..2) {
is_deeply( test($json, q!{foo:"foo"}! ), {foo=>'foo'} );
JSON->new->allow_singlequote(0);
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 04:56:37 +0000