This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
JSON-PP: customized VERSION bump
[perl5.git] / cpan / JSON-PP / lib / JSON / PP.pm
CommitLineData
d5424315
DG
1package JSON::PP;
2
3# JSON-2.0
4
5use 5.005;
6use strict;
7use base qw(Exporter);
8use overload ();
9
10use Carp ();
11use B ();
12#use Devel::Peek;
13
99d42275 14$JSON::PP::VERSION = '2.27400_02';
d5424315
DG
15
16@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
17
18# instead of hash-access, i tried index-access for speed.
19# but this method is not faster than what i expected. so it will be changed.
20
21use constant P_ASCII => 0;
22use constant P_LATIN1 => 1;
23use constant P_UTF8 => 2;
24use constant P_INDENT => 3;
25use constant P_CANONICAL => 4;
26use constant P_SPACE_BEFORE => 5;
27use constant P_SPACE_AFTER => 6;
28use constant P_ALLOW_NONREF => 7;
29use constant P_SHRINK => 8;
30use constant P_ALLOW_BLESSED => 9;
31use constant P_CONVERT_BLESSED => 10;
32use constant P_RELAXED => 11;
33
34use constant P_LOOSE => 12;
35use constant P_ALLOW_BIGNUM => 13;
36use constant P_ALLOW_BAREKEY => 14;
37use constant P_ALLOW_SINGLEQUOTE => 15;
38use constant P_ESCAPE_SLASH => 16;
39use constant P_AS_NONBLESSED => 17;
40
41use constant P_ALLOW_UNKNOWN => 18;
42
43use constant OLD_PERL => $] < 5.008 ? 1 : 0;
44
45BEGIN {
46 my @xs_compati_bit_properties = qw(
47 latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
48 allow_blessed convert_blessed relaxed allow_unknown
49 );
50 my @pp_bit_properties = qw(
51 allow_singlequote allow_bignum loose
52 allow_barekey escape_slash as_nonblessed
53 );
54
a1e5c561 55 # Perl version check, Unicode handling is enabled?
d5424315
DG
56 # Helper module sets @JSON::PP::_properties.
57 if ($] < 5.008 ) {
58 my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
59 eval qq| require $helper |;
60 if ($@) { Carp::croak $@; }
61 }
62
63 for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
64 my $flag_name = 'P_' . uc($name);
65
66 eval qq/
67 sub $name {
68 my \$enable = defined \$_[1] ? \$_[1] : 1;
69
70 if (\$enable) {
71 \$_[0]->{PROPS}->[$flag_name] = 1;
72 }
73 else {
74 \$_[0]->{PROPS}->[$flag_name] = 0;
75 }
76
77 \$_[0];
78 }
79
80 sub get_$name {
81 \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
82 }
83 /;
84 }
85
86}
87
88
89
90# Functions
91
92my %encode_allow_method
93 = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
94 allow_blessed convert_blessed indent indent_length allow_bignum
95 as_nonblessed
96 /;
97my %decode_allow_method
98 = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
99 allow_barekey max_size relaxed/;
100
101
102my $JSON; # cache
103
104sub encode_json ($) { # encode
105 ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
106}
107
108
109sub decode_json { # decode
110 ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
111}
112
113# Obsoleted
114
115sub to_json($) {
116 Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
117}
118
119
120sub from_json($) {
121 Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
122}
123
124
125# Methods
126
127sub new {
128 my $class = shift;
129 my $self = {
130 max_depth => 512,
131 max_size => 0,
132 indent => 0,
133 FLAGS => 0,
134 fallback => sub { encode_error('Invalid value. JSON can only reference.') },
135 indent_length => 3,
136 };
137
138 bless $self, $class;
139}
140
141
142sub encode {
143 return $_[0]->PP_encode_json($_[1]);
144}
145
146
147sub decode {
148 return $_[0]->PP_decode_json($_[1], 0x00000000);
149}
150
151
152sub decode_prefix {
153 return $_[0]->PP_decode_json($_[1], 0x00000001);
154}
155
156
157# accessor
158
159
160# pretty printing
161
162sub pretty {
163 my ($self, $v) = @_;
164 my $enable = defined $v ? $v : 1;
165
166 if ($enable) { # indent_length(3) for JSON::XS compatibility
167 $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
168 }
169 else {
170 $self->indent(0)->space_before(0)->space_after(0);
171 }
172
173 $self;
174}
175
176# etc
177
178sub max_depth {
179 my $max = defined $_[1] ? $_[1] : 0x80000000;
180 $_[0]->{max_depth} = $max;
181 $_[0];
182}
183
184
185sub get_max_depth { $_[0]->{max_depth}; }
186
187
188sub max_size {
189 my $max = defined $_[1] ? $_[1] : 0;
190 $_[0]->{max_size} = $max;
191 $_[0];
192}
193
194
195sub get_max_size { $_[0]->{max_size}; }
196
197
198sub filter_json_object {
199 $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
200 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
201 $_[0];
202}
203
204sub filter_json_single_key_object {
205 if (@_ > 1) {
206 $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
207 }
208 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
209 $_[0];
210}
211
212sub indent_length {
213 if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
214 Carp::carp "The acceptable range of indent_length() is 0 to 15.";
215 }
216 else {
217 $_[0]->{indent_length} = $_[1];
218 }
219 $_[0];
220}
221
222sub get_indent_length {
223 $_[0]->{indent_length};
224}
225
226sub sort_by {
227 $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
228 $_[0];
229}
230
231sub allow_bigint {
232 Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
233}
234
235###############################
236
237###
238### Perl => JSON
239###
240
241
242{ # Convert
243
244 my $max_depth;
245 my $indent;
246 my $ascii;
247 my $latin1;
248 my $utf8;
249 my $space_before;
250 my $space_after;
251 my $canonical;
252 my $allow_blessed;
253 my $convert_blessed;
254
255 my $indent_length;
256 my $escape_slash;
257 my $bignum;
258 my $as_nonblessed;
259
260 my $depth;
261 my $indent_count;
262 my $keysort;
263
264
265 sub PP_encode_json {
266 my $self = shift;
267 my $obj = shift;
268
269 $indent_count = 0;
270 $depth = 0;
271
272 my $idx = $self->{PROPS};
273
274 ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
275 $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
276 = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
277 P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
278
279 ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
280
281 $keysort = $canonical ? sub { $a cmp $b } : undef;
282
283 if ($self->{sort_by}) {
284 $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
285 : $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
286 : sub { $a cmp $b };
287 }
288
289 encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
290 if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
291
292 my $str = $self->object_to_json($obj);
293
294 $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
295
296 unless ($ascii or $latin1 or $utf8) {
297 utf8::upgrade($str);
298 }
299
300 if ($idx->[ P_SHRINK ]) {
301 utf8::downgrade($str, 1);
302 }
303
304 return $str;
305 }
306
307
308 sub object_to_json {
309 my ($self, $obj) = @_;
310 my $type = ref($obj);
311
312 if($type eq 'HASH'){
313 return $self->hash_to_json($obj);
314 }
315 elsif($type eq 'ARRAY'){
316 return $self->array_to_json($obj);
317 }
318 elsif ($type) { # blessed object?
319 if (blessed($obj)) {
320
321 return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
322
323 if ( $convert_blessed and $obj->can('TO_JSON') ) {
324 my $result = $obj->TO_JSON();
05bd2440
CBW
325 if ( defined $result and ref( $result ) ) {
326 if ( refaddr( $obj ) eq refaddr( $result ) ) {
d5424315
DG
327 encode_error( sprintf(
328 "%s::TO_JSON method returned same object as was passed instead of a new one",
329 ref $obj
330 ) );
331 }
332 }
333
334 return $self->object_to_json( $result );
335 }
336
337 return "$obj" if ( $bignum and _is_bignum($obj) );
338 return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
339
340 encode_error( sprintf("encountered object '%s', but neither allow_blessed "
341 . "nor convert_blessed settings are enabled", $obj)
342 ) unless ($allow_blessed);
343
344 return 'null';
345 }
346 else {
347 return $self->value_to_json($obj);
348 }
349 }
350 else{
351 return $self->value_to_json($obj);
352 }
353 }
354
355
356 sub hash_to_json {
357 my ($self, $obj) = @_;
358 my @res;
359
360 encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
361 if (++$depth > $max_depth);
362
363 my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
364 my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
365
366 for my $k ( _sort( $obj ) ) {
367 if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
368 push @res, string_to_json( $self, $k )
369 . $del
370 . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
371 }
372
373 --$depth;
374 $self->_down_indent() if ($indent);
375
376 return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}';
377 }
378
379
380 sub array_to_json {
381 my ($self, $obj) = @_;
382 my @res;
383
384 encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
385 if (++$depth > $max_depth);
386
387 my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
388
389 for my $v (@$obj){
390 push @res, $self->object_to_json($v) || $self->value_to_json($v);
391 }
392
393 --$depth;
394 $self->_down_indent() if ($indent);
395
396 return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
397 }
398
399
400 sub value_to_json {
401 my ($self, $value) = @_;
402
403 return 'null' if(!defined $value);
404
405 my $b_obj = B::svref_2object(\$value); # for round trip problem
406 my $flags = $b_obj->FLAGS;
407
408 return $value # as is
409 if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
410
411 my $type = ref($value);
412
413 if(!$type){
414 return string_to_json($self, $value);
415 }
416 elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
417 return $$value == 1 ? 'true' : 'false';
418 }
419 elsif ($type) {
420 if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
421 return $self->value_to_json("$value");
422 }
423
424 if ($type eq 'SCALAR' and defined $$value) {
425 return $$value eq '1' ? 'true'
426 : $$value eq '0' ? 'false'
427 : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
428 : encode_error("cannot encode reference to scalar");
429 }
430
431 if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
432 return 'null';
433 }
434 else {
435 if ( $type eq 'SCALAR' or $type eq 'REF' ) {
436 encode_error("cannot encode reference to scalar");
437 }
438 else {
439 encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
440 }
441 }
442
443 }
444 else {
445 return $self->{fallback}->($value)
446 if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
447 return 'null';
448 }
449
450 }
451
452
453 my %esc = (
454 "\n" => '\n',
455 "\r" => '\r',
456 "\t" => '\t',
457 "\f" => '\f',
458 "\b" => '\b',
459 "\"" => '\"',
460 "\\" => '\\\\',
461 "\'" => '\\\'',
462 );
463
464
465 sub string_to_json {
466 my ($self, $arg) = @_;
467
468 $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
469 $arg =~ s/\//\\\//g if ($escape_slash);
470 $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
471
472 if ($ascii) {
473 $arg = JSON_PP_encode_ascii($arg);
474 }
475
476 if ($latin1) {
477 $arg = JSON_PP_encode_latin1($arg);
478 }
479
480 if ($utf8) {
481 utf8::encode($arg);
482 }
483
484 return '"' . $arg . '"';
485 }
486
487
488 sub blessed_to_json {
489 my $reftype = reftype($_[1]) || '';
490 if ($reftype eq 'HASH') {
491 return $_[0]->hash_to_json($_[1]);
492 }
493 elsif ($reftype eq 'ARRAY') {
494 return $_[0]->array_to_json($_[1]);
495 }
496 else {
497 return 'null';
498 }
499 }
500
501
502 sub encode_error {
503 my $error = shift;
504 Carp::croak "$error";
505 }
506
507
508 sub _sort {
509 defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
510 }
511
512
513 sub _up_indent {
514 my $self = shift;
515 my $space = ' ' x $indent_length;
516
517 my ($pre,$post) = ('','');
518
519 $post = "\n" . $space x $indent_count;
520
521 $indent_count++;
522
523 $pre = "\n" . $space x $indent_count;
524
525 return ($pre,$post);
526 }
527
528
529 sub _down_indent { $indent_count--; }
530
531
532 sub PP_encode_box {
533 {
534 depth => $depth,
535 indent_count => $indent_count,
536 };
537 }
538
539} # Convert
540
541
542sub _encode_ascii {
543 join('',
544 map {
545 $_ <= 127 ?
546 chr($_) :
547 $_ <= 65535 ?
548 sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
549 } unpack('U*', $_[0])
550 );
551}
552
553
554sub _encode_latin1 {
555 join('',
556 map {
557 $_ <= 255 ?
558 chr($_) :
559 $_ <= 65535 ?
560 sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
561 } unpack('U*', $_[0])
562 );
563}
564
565
566sub _encode_surrogates { # from perlunicode
567 my $uni = $_[0] - 0x10000;
568 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
569}
570
571
572sub _is_bignum {
573 $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
574}
575
576
577
578#
579# JSON => Perl
580#
581
582my $max_intsize;
583
584BEGIN {
585 my $checkint = 1111;
586 for my $d (5..64) {
587 $checkint .= 1;
588 my $int = eval qq| $checkint |;
589 if ($int =~ /[eE]/) {
590 $max_intsize = $d - 1;
591 last;
592 }
593 }
594}
595
596{ # PARSE
597
598 my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
599 b => "\x8",
600 t => "\x9",
601 n => "\xA",
602 f => "\xC",
603 r => "\xD",
604 '\\' => '\\',
605 '"' => '"',
606 '/' => '/',
607 );
608
609 my $text; # json data
610 my $at; # offset
a1e5c561 611 my $ch; # first character
d5424315
DG
612 my $len; # text length (changed according to UTF8 or NON UTF8)
613 # INTERNAL
614 my $depth; # nest counter
615 my $encoding; # json text encoding
616 my $is_valid_utf8; # temp variable
617 my $utf8_len; # utf8 byte length
618 # FLAGS
619 my $utf8; # must be utf8
a1e5c561 620 my $max_depth; # max nest number of objects and arrays
d5424315
DG
621 my $max_size;
622 my $relaxed;
623 my $cb_object;
624 my $cb_sk_object;
625
626 my $F_HOOK;
627
628 my $allow_bigint; # using Math::BigInt
629 my $singlequote; # loosely quoting
630 my $loose; #
631 my $allow_barekey; # bareKey
632
633 # $opt flag
634 # 0x00000001 .... decode_prefix
635 # 0x10000000 .... incr_parse
636
637 sub PP_decode_json {
638 my ($self, $opt); # $opt is an effective flag during this decode_json.
639
640 ($self, $text, $opt) = @_;
641
642 ($at, $ch, $depth) = (0, '', 0);
643
644 if ( !defined $text or ref $text ) {
645 decode_error("malformed JSON string, neither array, object, number, string or atom");
646 }
647
648 my $idx = $self->{PROPS};
649
650 ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
651 = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
652
653 if ( $utf8 ) {
654 utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
655 }
656 else {
657 utf8::upgrade( $text );
87f3ebe4 658 utf8::encode( $text );
d5424315
DG
659 }
660
661 $len = length $text;
662
663 ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
664 = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
665
666 if ($max_size > 1) {
667 use bytes;
668 my $bytes = length $text;
669 decode_error(
670 sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
671 , $bytes, $max_size), 1
672 ) if ($bytes > $max_size);
673 }
674
675 # Currently no effect
676 # should use regexp
677 my @octets = unpack('C4', $text);
678 $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
679 : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
680 : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
681 : ( $octets[2] ) ? 'UTF-16LE'
682 : (!$octets[2] ) ? 'UTF-32LE'
683 : 'unknown';
684
685 white(); # remove head white space
686
687 my $valid_start = defined $ch; # Is there a first character for JSON structure?
688
689 my $result = value();
690
691 return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
692
693 decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
694
695 if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
696 decode_error(
697 'JSON text must be an object or array (but found number, string, true, false or null,'
698 . ' use allow_nonref to allow this)', 1);
699 }
700
701 Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
702
703 my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
704
705 white(); # remove tail white space
706
707 if ( $ch ) {
708 return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
709 decode_error("garbage after JSON object");
710 }
711
712 ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
713 }
714
715
716 sub next_chr {
717 return $ch = undef if($at >= $len);
718 $ch = substr($text, $at++, 1);
719 }
720
721
722 sub value {
723 white();
724 return if(!defined $ch);
725 return object() if($ch eq '{');
726 return array() if($ch eq '[');
727 return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
728 return number() if($ch =~ /[0-9]/ or $ch eq '-');
729 return word();
730 }
731
732 sub string {
733 my ($i, $s, $t, $u);
734 my $utf16;
735 my $is_utf8;
736
737 ($is_valid_utf8, $utf8_len) = ('', 0);
738
739 $s = ''; # basically UTF8 flag on
740
741 if($ch eq '"' or ($singlequote and $ch eq "'")){
742 my $boundChar = $ch;
743
744 OUTER: while( defined(next_chr()) ){
745
746 if($ch eq $boundChar){
747 next_chr();
748
749 if ($utf16) {
750 decode_error("missing low surrogate character in surrogate pair");
751 }
752
753 utf8::decode($s) if($is_utf8);
754
755 return $s;
756 }
757 elsif($ch eq '\\'){
758 next_chr();
759 if(exists $escapes{$ch}){
760 $s .= $escapes{$ch};
761 }
762 elsif($ch eq 'u'){ # UNICODE handling
763 my $u = '';
764
765 for(1..4){
766 $ch = next_chr();
767 last OUTER if($ch !~ /[0-9a-fA-F]/);
768 $u .= $ch;
769 }
770
771 # U+D800 - U+DBFF
772 if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
773 $utf16 = $u;
774 }
775 # U+DC00 - U+DFFF
776 elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
777 unless (defined $utf16) {
778 decode_error("missing high surrogate character in surrogate pair");
779 }
780 $is_utf8 = 1;
781 $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
782 $utf16 = undef;
783 }
784 else {
785 if (defined $utf16) {
786 decode_error("surrogate pair expected");
787 }
788
789 if ( ( my $hex = hex( $u ) ) > 127 ) {
790 $is_utf8 = 1;
791 $s .= JSON_PP_decode_unicode($u) || next;
792 }
793 else {
794 $s .= chr $hex;
795 }
796 }
797
798 }
799 else{
800 unless ($loose) {
801 $at -= 2;
802 decode_error('illegal backslash escape sequence in string');
803 }
804 $s .= $ch;
805 }
806 }
807 else{
808
809 if ( ord $ch > 127 ) {
87f3ebe4
CBW
810 unless( $ch = is_valid_utf8($ch) ) {
811 $at -= 1;
812 decode_error("malformed UTF-8 character in JSON string");
d5424315
DG
813 }
814 else {
87f3ebe4 815 $at += $utf8_len - 1;
d5424315
DG
816 }
817
818 $is_utf8 = 1;
819 }
820
821 if (!$loose) {
822 if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
823 $at--;
824 decode_error('invalid character encountered while parsing JSON string');
825 }
826 }
827
828 $s .= $ch;
829 }
830 }
831 }
832
833 decode_error("unexpected end of string while parsing JSON string");
834 }
835
836
837 sub white {
838 while( defined $ch ){
839 if($ch le ' '){
840 next_chr();
841 }
842 elsif($ch eq '/'){
843 next_chr();
844 if(defined $ch and $ch eq '/'){
845 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
846 }
847 elsif(defined $ch and $ch eq '*'){
848 next_chr();
849 while(1){
850 if(defined $ch){
851 if($ch eq '*'){
852 if(defined(next_chr()) and $ch eq '/'){
853 next_chr();
854 last;
855 }
856 }
857 else{
858 next_chr();
859 }
860 }
861 else{
862 decode_error("Unterminated comment");
863 }
864 }
865 next;
866 }
867 else{
868 $at--;
869 decode_error("malformed JSON string, neither array, object, number, string or atom");
870 }
871 }
872 else{
873 if ($relaxed and $ch eq '#') { # correctly?
874 pos($text) = $at;
875 $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
876 $at = pos($text);
877 next_chr;
878 next;
879 }
880
881 last;
882 }
883 }
884 }
885
886
887 sub array {
05bd2440 888 my $a = $_[0] || []; # you can use this code to use another array ref object.
d5424315
DG
889
890 decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
891 if (++$depth > $max_depth);
892
893 next_chr();
894 white();
895
896 if(defined $ch and $ch eq ']'){
897 --$depth;
898 next_chr();
899 return $a;
900 }
901 else {
902 while(defined($ch)){
903 push @$a, value();
904
905 white();
906
907 if (!defined $ch) {
908 last;
909 }
910
911 if($ch eq ']'){
912 --$depth;
913 next_chr();
914 return $a;
915 }
916
917 if($ch ne ','){
918 last;
919 }
920
921 next_chr();
922 white();
923
924 if ($relaxed and $ch eq ']') {
925 --$depth;
926 next_chr();
927 return $a;
928 }
929
930 }
931 }
932
933 decode_error(", or ] expected while parsing array");
934 }
935
936
937 sub object {
05bd2440 938 my $o = $_[0] || {}; # you can use this code to use another hash ref object.
d5424315
DG
939 my $k;
940
941 decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
942 if (++$depth > $max_depth);
943 next_chr();
944 white();
945
946 if(defined $ch and $ch eq '}'){
947 --$depth;
948 next_chr();
949 if ($F_HOOK) {
950 return _json_object_hook($o);
951 }
952 return $o;
953 }
954 else {
955 while (defined $ch) {
956 $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
957 white();
958
959 if(!defined $ch or $ch ne ':'){
960 $at--;
961 decode_error("':' expected");
962 }
963
964 next_chr();
965 $o->{$k} = value();
966 white();
967
968 last if (!defined $ch);
969
970 if($ch eq '}'){
971 --$depth;
972 next_chr();
973 if ($F_HOOK) {
974 return _json_object_hook($o);
975 }
976 return $o;
977 }
978
979 if($ch ne ','){
980 last;
981 }
982
983 next_chr();
984 white();
985
986 if ($relaxed and $ch eq '}') {
987 --$depth;
988 next_chr();
989 if ($F_HOOK) {
990 return _json_object_hook($o);
991 }
992 return $o;
993 }
994
995 }
996
997 }
998
999 $at--;
1000 decode_error(", or } expected while parsing object/hash");
1001 }
1002
1003
1004 sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
1005 my $key;
1006 while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
1007 $key .= $ch;
1008 next_chr();
1009 }
1010 return $key;
1011 }
1012
1013
1014 sub word {
1015 my $word = substr($text,$at-1,4);
1016
1017 if($word eq 'true'){
1018 $at += 3;
1019 next_chr;
1020 return $JSON::PP::true;
1021 }
1022 elsif($word eq 'null'){
1023 $at += 3;
1024 next_chr;
1025 return undef;
1026 }
1027 elsif($word eq 'fals'){
1028 $at += 3;
1029 if(substr($text,$at,1) eq 'e'){
1030 $at++;
1031 next_chr;
1032 return $JSON::PP::false;
1033 }
1034 }
1035
1036 $at--; # for decode_error report
1037
1038 decode_error("'null' expected") if ($word =~ /^n/);
1039 decode_error("'true' expected") if ($word =~ /^t/);
1040 decode_error("'false' expected") if ($word =~ /^f/);
1041 decode_error("malformed JSON string, neither array, object, number, string or atom");
1042 }
1043
1044
1045 sub number {
1046 my $n = '';
1047 my $v;
a1e5c561 1048 my $is_dec;
d5424315 1049
a1e5c561 1050 # According to RFC4627, hex or oct digits are invalid.
d5424315
DG
1051 if($ch eq '0'){
1052 my $peek = substr($text,$at,1);
1053 my $hex = $peek =~ /[xX]/; # 0 or 1
1054
1055 if($hex){
1056 decode_error("malformed number (leading zero must not be followed by another digit)");
1057 ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
1058 }
1059 else{ # oct
1060 ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
1061 if (defined $n and length $n > 1) {
1062 decode_error("malformed number (leading zero must not be followed by another digit)");
1063 }
1064 }
1065
1066 if(defined $n and length($n)){
1067 if (!$hex and length($n) == 1) {
1068 decode_error("malformed number (leading zero must not be followed by another digit)");
1069 }
1070 $at += length($n) + $hex;
1071 next_chr;
1072 return $hex ? hex($n) : oct($n);
1073 }
1074 }
1075
1076 if($ch eq '-'){
1077 $n = '-';
1078 next_chr;
1079 if (!defined $ch or $ch !~ /\d/) {
1080 decode_error("malformed number (no digits after initial minus)");
1081 }
1082 }
1083
1084 while(defined $ch and $ch =~ /\d/){
1085 $n .= $ch;
1086 next_chr;
1087 }
1088
1089 if(defined $ch and $ch eq '.'){
1090 $n .= '.';
a1e5c561 1091 $is_dec = 1;
d5424315
DG
1092
1093 next_chr;
1094 if (!defined $ch or $ch !~ /\d/) {
1095 decode_error("malformed number (no digits after decimal point)");
1096 }
1097 else {
1098 $n .= $ch;
1099 }
1100
1101 while(defined(next_chr) and $ch =~ /\d/){
1102 $n .= $ch;
1103 }
1104 }
1105
1106 if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
1107 $n .= $ch;
1108 next_chr;
1109
1110 if(defined($ch) and ($ch eq '+' or $ch eq '-')){
1111 $n .= $ch;
1112 next_chr;
1113 if (!defined $ch or $ch =~ /\D/) {
1114 decode_error("malformed number (no digits after exp sign)");
1115 }
1116 $n .= $ch;
1117 }
1118 elsif(defined($ch) and $ch =~ /\d/){
1119 $n .= $ch;
1120 }
1121 else {
1122 decode_error("malformed number (no digits after exp sign)");
1123 }
1124
1125 while(defined(next_chr) and $ch =~ /\d/){
1126 $n .= $ch;
1127 }
1128
1129 }
1130
1131 $v .= $n;
1132
1133 if ($v !~ /[.eE]/ and length $v > $max_intsize) {
1134 if ($allow_bigint) { # from Adam Sussman
1135 require Math::BigInt;
1136 return Math::BigInt->new($v);
1137 }
1138 else {
1139 return "$v";
1140 }
1141 }
1142 elsif ($allow_bigint) {
1143 require Math::BigFloat;
1144 return Math::BigFloat->new($v);
1145 }
1146
a1e5c561 1147 return $is_dec ? $v/1.0 : 0+$v;
d5424315
DG
1148 }
1149
1150
1151 sub is_valid_utf8 {
1152
1153 $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
1154 : $_[0] =~ /[\xC2-\xDF]/ ? 2
1155 : $_[0] =~ /[\xE0-\xEF]/ ? 3
1156 : $_[0] =~ /[\xF0-\xF4]/ ? 4
1157 : 0
1158 ;
1159
1160 return unless $utf8_len;
1161
1162 my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
1163
1164 return ( $is_valid_utf8 =~ /^(?:
1165 [\x00-\x7F]
1166 |[\xC2-\xDF][\x80-\xBF]
1167 |[\xE0][\xA0-\xBF][\x80-\xBF]
1168 |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
1169 |[\xED][\x80-\x9F][\x80-\xBF]
1170 |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
1171 |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
1172 |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
1173 |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
1174 )$/x ) ? $is_valid_utf8 : '';
1175 }
1176
1177
1178 sub decode_error {
1179 my $error = shift;
1180 my $no_rep = shift;
1181 my $str = defined $text ? substr($text, $at) : '';
1182 my $mess = '';
1183 my $type = $] >= 5.008 ? 'U*'
1184 : $] < 5.006 ? 'C*'
1185 : utf8::is_utf8( $str ) ? 'U*' # 5.6
1186 : 'C*'
1187 ;
1188
1189 for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
1190 $mess .= $c == 0x07 ? '\a'
1191 : $c == 0x09 ? '\t'
1192 : $c == 0x0a ? '\n'
1193 : $c == 0x0d ? '\r'
1194 : $c == 0x0c ? '\f'
1195 : $c < 0x20 ? sprintf('\x{%x}', $c)
1196 : $c == 0x5c ? '\\\\'
1197 : $c < 0x80 ? chr($c)
1198 : sprintf('\x{%x}', $c)
1199 ;
1200 if ( length $mess >= 20 ) {
1201 $mess .= '...';
1202 last;
1203 }
1204 }
1205
1206 unless ( length $mess ) {
1207 $mess = '(end of string)';
1208 }
1209
1210 Carp::croak (
1211 $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
1212 );
1213
1214 }
1215
1216
1217 sub _json_object_hook {
1218 my $o = $_[0];
1219 my @ks = keys %{$o};
1220
1221 if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
1222 my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
1223 if (@val == 1) {
1224 return $val[0];
1225 }
1226 }
1227
1228 my @val = $cb_object->($o) if ($cb_object);
1229 if (@val == 0 or @val > 1) {
1230 return $o;
1231 }
1232 else {
1233 return $val[0];
1234 }
1235 }
1236
1237
1238 sub PP_decode_box {
1239 {
1240 text => $text,
1241 at => $at,
1242 ch => $ch,
1243 len => $len,
1244 depth => $depth,
1245 encoding => $encoding,
1246 is_valid_utf8 => $is_valid_utf8,
1247 };
1248 }
1249
1250} # PARSE
1251
1252
1253sub _decode_surrogates { # from perlunicode
1254 my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
1255 my $un = pack('U*', $uni);
1256 utf8::encode( $un );
1257 return $un;
1258}
1259
1260
1261sub _decode_unicode {
1262 my $un = pack('U', hex shift);
1263 utf8::encode( $un );
1264 return $un;
1265}
1266
1267#
1268# Setup for various Perl versions (the code from JSON::PP58)
1269#
1270
1271BEGIN {
1272
1273 unless ( defined &utf8::is_utf8 ) {
1274 require Encode;
1275 *utf8::is_utf8 = *Encode::is_utf8;
1276 }
1277
1278 if ( $] >= 5.008 ) {
1279 *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
1280 *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
1281 *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
1282 *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
1283 }
1284
1285 if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
1286 package JSON::PP;
1287 require subs;
1288 subs->import('join');
1289 eval q|
1290 sub join {
1291 return '' if (@_ < 2);
1292 my $j = shift;
1293 my $str = shift;
1294 for (@_) { $str .= $j . $_; }
1295 return $str;
1296 }
1297 |;
1298 }
1299
1300
1301 sub JSON::PP::incr_parse {
1302 local $Carp::CarpLevel = 1;
1303 ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
1304 }
1305
1306
1307 sub JSON::PP::incr_skip {
1308 ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
1309 }
1310
1311
1312 sub JSON::PP::incr_reset {
1313 ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
1314 }
1315
1316 eval q{
1317 sub JSON::PP::incr_text : lvalue {
1318 $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
1319
1320 if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
a1e5c561 1321 Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
d5424315
DG
1322 }
1323 $_[0]->{_incr_parser}->{incr_text};
1324 }
1325 } if ( $] >= 5.006 );
1326
1327} # Setup for various Perl versions (the code from JSON::PP58)
1328
1329
1330###############################
1331# Utilities
1332#
1333
1334BEGIN {
1335 eval 'require Scalar::Util';
1336 unless($@){
1337 *JSON::PP::blessed = \&Scalar::Util::blessed;
1338 *JSON::PP::reftype = \&Scalar::Util::reftype;
05bd2440 1339 *JSON::PP::refaddr = \&Scalar::Util::refaddr;
d5424315
DG
1340 }
1341 else{ # This code is from Sclar::Util.
1342 # warn $@;
1343 eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
1344 *JSON::PP::blessed = sub {
1345 local($@, $SIG{__DIE__}, $SIG{__WARN__});
1346 ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
1347 };
1348 my %tmap = qw(
1349 B::NULL SCALAR
1350 B::HV HASH
1351 B::AV ARRAY
1352 B::CV CODE
1353 B::IO IO
1354 B::GV GLOB
1355 B::REGEXP REGEXP
1356 );
1357 *JSON::PP::reftype = sub {
1358 my $r = shift;
1359
1360 return undef unless length(ref($r));
1361
1362 my $t = ref(B::svref_2object($r));
1363
1364 return
1365 exists $tmap{$t} ? $tmap{$t}
1366 : length(ref($$r)) ? 'REF'
1367 : 'SCALAR';
1368 };
05bd2440
CBW
1369 *JSON::PP::refaddr = sub {
1370 return undef unless length(ref($_[0]));
1371
1372 my $addr;
1373 if(defined(my $pkg = blessed($_[0]))) {
1374 $addr .= bless $_[0], 'Scalar::Util::Fake';
1375 bless $_[0], $pkg;
1376 }
1377 else {
1378 $addr .= $_[0]
1379 }
1380
1381 $addr =~ /0x(\w+)/;
1382 local $^W;
1383 #no warnings 'portable';
1384 hex($1);
1385 }
d5424315
DG
1386 }
1387}
1388
1389
a1e5c561 1390# shamelessly copied and modified from JSON::XS code.
d5424315
DG
1391
1392$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
1393$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1394
1395sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
1396
1397sub true { $JSON::PP::true }
1398sub false { $JSON::PP::false }
1399sub null { undef; }
1400
1401###############################
1402
1403package JSON::PP::Boolean;
1404
d5424315
DG
1405use overload (
1406 "0+" => sub { ${$_[0]} },
1407 "++" => sub { $_[0] = ${$_[0]} + 1 },
1408 "--" => sub { $_[0] = ${$_[0]} - 1 },
1409 fallback => 1,
1410);
1411
1412
1413###############################
1414
1415package JSON::PP::IncrParser;
1416
1417use strict;
1418
1419use constant INCR_M_WS => 0; # initial whitespace skipping
1420use constant INCR_M_STR => 1; # inside string
1421use constant INCR_M_BS => 2; # inside backslash
1422use constant INCR_M_JSON => 3; # outside anything, count nesting
1423use constant INCR_M_C0 => 4;
1424use constant INCR_M_C1 => 5;
1425
1426$JSON::PP::IncrParser::VERSION = '1.01';
1427
1428my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
1429
1430sub new {
1431 my ( $class ) = @_;
1432
1433 bless {
1434 incr_nest => 0,
1435 incr_text => undef,
1436 incr_parsing => 0,
1437 incr_p => 0,
1438 }, $class;
1439}
1440
1441
1442sub incr_parse {
1443 my ( $self, $coder, $text ) = @_;
1444
1445 $self->{incr_text} = '' unless ( defined $self->{incr_text} );
1446
1447 if ( defined $text ) {
1448 if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
1449 utf8::upgrade( $self->{incr_text} ) ;
1450 utf8::decode( $self->{incr_text} ) ;
1451 }
1452 $self->{incr_text} .= $text;
1453 }
1454
1455
1456 my $max_size = $coder->get_max_size;
1457
1458 if ( defined wantarray ) {
1459
7942a65c 1460 $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
d5424315
DG
1461
1462 if ( wantarray ) {
1463 my @ret;
1464
1465 $self->{incr_parsing} = 1;
1466
1467 do {
1468 push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
1469
1470 unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
7942a65c 1471 $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
d5424315
DG
1472 }
1473
7942a65c 1474 } until ( length $self->{incr_text} >= $self->{incr_p} );
d5424315
DG
1475
1476 $self->{incr_parsing} = 0;
1477
1478 return @ret;
1479 }
1480 else { # in scalar context
1481 $self->{incr_parsing} = 1;
1482 my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
1483 $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
1484 return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
1485 }
1486
1487 }
1488
1489}
1490
1491
1492sub _incr_parse {
1493 my ( $self, $coder, $text, $skip ) = @_;
1494 my $p = $self->{incr_p};
1495 my $restore = $p;
1496
1497 my @obj;
1498 my $len = length $text;
1499
1500 if ( $self->{incr_mode} == INCR_M_WS ) {
1501 while ( $len > $p ) {
1502 my $s = substr( $text, $p, 1 );
1503 $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
1504 $self->{incr_mode} = INCR_M_JSON;
1505 last;
1506 }
1507 }
1508
1509 while ( $len > $p ) {
1510 my $s = substr( $text, $p++, 1 );
1511
1512 if ( $s eq '"' ) {
7942a65c
CBW
1513 if (substr( $text, $p - 2, 1 ) eq '\\' ) {
1514 next;
1515 }
1516
d5424315
DG
1517 if ( $self->{incr_mode} != INCR_M_STR ) {
1518 $self->{incr_mode} = INCR_M_STR;
1519 }
1520 else {
1521 $self->{incr_mode} = INCR_M_JSON;
1522 unless ( $self->{incr_nest} ) {
1523 last;
1524 }
1525 }
1526 }
1527
1528 if ( $self->{incr_mode} == INCR_M_JSON ) {
1529
1530 if ( $s eq '[' or $s eq '{' ) {
1531 if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
1532 Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
1533 }
1534 }
1535 elsif ( $s eq ']' or $s eq '}' ) {
1536 last if ( --$self->{incr_nest} <= 0 );
1537 }
1538 elsif ( $s eq '#' ) {
1539 while ( $len > $p ) {
1540 last if substr( $text, $p++, 1 ) eq "\n";
1541 }
1542 }
1543
1544 }
1545
1546 }
1547
1548 $self->{incr_p} = $p;
1549
7942a65c 1550 return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
d5424315
DG
1551 return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
1552
1553 return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
1554
1555 local $Carp::CarpLevel = 2;
1556
1557 $self->{incr_p} = $restore;
1558 $self->{incr_c} = $p;
1559
1560 my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
1561
1562 $self->{incr_text} = substr( $self->{incr_text}, $p );
1563 $self->{incr_p} = 0;
1564
4fa6bcb0 1565 return $obj || '';
d5424315
DG
1566}
1567
1568
1569sub incr_text {
1570 if ( $_[0]->{incr_parsing} ) {
a1e5c561 1571 Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
d5424315
DG
1572 }
1573 $_[0]->{incr_text};
1574}
1575
1576
1577sub incr_skip {
1578 my $self = shift;
1579 $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
1580 $self->{incr_p} = 0;
1581}
1582
1583
1584sub incr_reset {
1585 my $self = shift;
1586 $self->{incr_text} = undef;
1587 $self->{incr_p} = 0;
1588 $self->{incr_mode} = 0;
1589 $self->{incr_nest} = 0;
1590 $self->{incr_parsing} = 0;
1591}
1592
1593###############################
1594
1595
15961;
1597__END__
1598=pod
1599
1600=head1 NAME
1601
1602JSON::PP - JSON::XS compatible pure-Perl module.
1603
1604=head1 SYNOPSIS
1605
1606 use JSON::PP;
1607
1608 # exported functions, they croak on error
1609 # and expect/generate UTF-8
1610
1611 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
1612 $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
1613
1614 # OO-interface
1615
1616 $coder = JSON::PP->new->ascii->pretty->allow_nonref;
1617
1618 $json_text = $json->encode( $perl_scalar );
1619 $perl_scalar = $json->decode( $json_text );
1620
1621 $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
1622
1623 # Note that JSON version 2.0 and above will automatically use
1624 # JSON::XS or JSON::PP, so you should be able to just:
1625
1626 use JSON;
1627
1628
1629=head1 VERSION
1630
a1e5c561 1631 2.27400
2ec5653d 1632
7942a65c 1633L<JSON::XS> 2.27 (~2.30) compatible.
d5424315
DG
1634
1635=head1 NOTE
1636
a1e5c561 1637JSON::PP had been included in JSON distribution (CPAN module).
16880a15 1638It was a perl core module in Perl 5.14.
d5424315
DG
1639
1640=head1 DESCRIPTION
1641
1642This module is L<JSON::XS> compatible pure Perl module.
1643(Perl 5.8 or later is recommended)
1644
1645JSON::XS is the fastest and most proper JSON module on CPAN.
1646It is written by Marc Lehmann in C, so must be compiled and
1647installed in the used environment.
1648
1649JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
1650
1651
1652=head2 FEATURES
1653
1654=over
1655
1656=item * correct unicode handling
1657
1658This module knows how to handle Unicode (depending on Perl version).
1659
1660See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
1661
1662
1663=item * round-trip integrity
1664
1665When you serialise a perl data structure using only data types supported
1666by JSON and Perl, the deserialised data structure is identical on the Perl
1667level. (e.g. the string "2.0" doesn't suddenly become "2" just because
1668it looks like a number). There I<are> minor exceptions to this, read the
1669MAPPING section below to learn about those.
1670
1671
1672=item * strict checking of JSON correctness
1673
1674There is no guessing, no generating of illegal JSON texts by default,
1675and only JSON is accepted as input by default (the latter is a security feature).
a1e5c561 1676But when some options are set, loose checking features are available.
d5424315
DG
1677
1678=back
1679
1680=head1 FUNCTIONAL INTERFACE
1681
1682Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
1683
1684=head2 encode_json
1685
1686 $json_text = encode_json $perl_scalar
1687
1688Converts the given Perl data structure to a UTF-8 encoded, binary string.
1689
1690This function call is functionally identical to:
1691
1692 $json_text = JSON::PP->new->utf8->encode($perl_scalar)
1693
1694=head2 decode_json
1695
1696 $perl_scalar = decode_json $json_text
1697
1698The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
1699to parse that as an UTF-8 encoded JSON text, returning the resulting
1700reference.
1701
1702This function call is functionally identical to:
1703
1704 $perl_scalar = JSON::PP->new->utf8->decode($json_text)
1705
1706=head2 JSON::PP::is_bool
1707
1708 $is_boolean = JSON::PP::is_bool($scalar)
1709
1710Returns true if the passed scalar represents either JSON::PP::true or
1711JSON::PP::false, two constants that act like C<1> and C<0> respectively
1712and are also used to represent JSON C<true> and C<false> in Perl strings.
1713
1714=head2 JSON::PP::true
1715
1716Returns JSON true value which is blessed object.
1717It C<isa> JSON::PP::Boolean object.
1718
1719=head2 JSON::PP::false
1720
1721Returns JSON false value which is blessed object.
1722It C<isa> JSON::PP::Boolean object.
1723
1724=head2 JSON::PP::null
1725
1726Returns C<undef>.
1727
1728See L<MAPPING>, below, for more information on how JSON values are mapped to
1729Perl.
1730
1731
1732=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
1733
a1e5c561 1734This section supposes that your perl version is 5.8 or later.
d5424315
DG
1735
1736If you know a JSON text from an outer world - a network, a file content, and so on,
1737is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
a1e5c561 1738with C<utf8> enabled. And the decoded result will contain UNICODE characters.
d5424315
DG
1739
1740 # from network
1741 my $json = JSON::PP->new->utf8;
1742 my $json_text = CGI->new->param( 'json_data' );
1743 my $perl_scalar = $json->decode( $json_text );
1744
1745 # from file content
1746 local $/;
1747 open( my $fh, '<', 'json.data' );
1748 $json_text = <$fh>;
1749 $perl_scalar = decode_json( $json_text );
1750
1751If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
1752
1753 use Encode;
1754 local $/;
1755 open( my $fh, '<', 'json.data' );
1756 my $encoding = 'cp932';
1757 my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
1758
1759 # or you can write the below code.
1760 #
1761 # open( my $fh, "<:encoding($encoding)", 'json.data' );
1762 # $unicode_json_text = <$fh>;
1763
1764In this case, C<$unicode_json_text> is of course UNICODE string.
a1e5c561 1765So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enabled.
d5424315
DG
1766Instead of them, you use C<JSON> module object with C<utf8> disable.
1767
1768 $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
1769
1770Or C<encode 'utf8'> and C<decode_json>:
1771
1772 $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
1773 # this way is not efficient.
1774
1775And now, you want to convert your C<$perl_scalar> into JSON data and
1776send it to an outer world - a network or a file content, and so on.
1777
1778Your data usually contains UNICODE strings and you want the converted data to be encoded
a1e5c561 1779in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enabled.
d5424315
DG
1780
1781 print encode_json( $perl_scalar ); # to a network? file? or display?
1782 # or
1783 print $json->utf8->encode( $perl_scalar );
1784
1785If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
1786for some reason, then its characters are regarded as B<latin1> for perl
1787(because it does not concern with your $encoding).
a1e5c561 1788You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enabled.
d5424315
DG
1789Instead of them, you use C<JSON> module object with C<utf8> disable.
1790Note that the resulted text is a UNICODE string but no problem to print it.
1791
1792 # $perl_scalar contains $encoding encoded string values
1793 $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
1794 # $unicode_json_text consists of characters less than 0x100
1795 print $unicode_json_text;
1796
1797Or C<decode $encoding> all string values and C<encode_json>:
1798
1799 $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
1800 # ... do it to each string values, then encode_json
1801 $json_text = encode_json( $perl_scalar );
1802
1803This method is a proper way but probably not efficient.
1804
1805See to L<Encode>, L<perluniintro>.
1806
1807
1808=head1 METHODS
1809
1810Basically, check to L<JSON> or L<JSON::XS>.
1811
1812=head2 new
1813
7942a65c 1814 $json = JSON::PP->new
d5424315 1815
a1e5c561 1816Returns a new JSON::PP object that can be used to de/encode JSON
d5424315
DG
1817strings.
1818
1819All boolean flags described below are by default I<disabled>.
1820
1821The mutators for flags all return the JSON object again and thus calls can
1822be chained:
1823
1824 my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
1825 => {"a": [1, 2]}
1826
1827=head2 ascii
1828
1829 $json = $json->ascii([$enable])
1830
1831 $enabled = $json->get_ascii
1832
1833If $enable is true (or missing), then the encode method will not generate characters outside
1834the code range 0..127. Any Unicode characters outside that range will be escaped using either
1835a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
1836(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
1837
1838In Perl 5.005, there is no character having high value (more than 255).
1839See to L<UNICODE HANDLING ON PERLS>.
1840
1841If $enable is false, then the encode method will not escape Unicode characters unless
1842required by the JSON syntax or other flags. This results in a faster and more compact format.
1843
1844 JSON::PP->new->ascii(1)->encode([chr 0x10401])
1845 => ["\ud801\udc01"]
1846
1847=head2 latin1
1848
1849 $json = $json->latin1([$enable])
1850
1851 $enabled = $json->get_latin1
1852
1853If $enable is true (or missing), then the encode method will encode the resulting JSON
1854text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
1855
1856If $enable is false, then the encode method will not escape Unicode characters
1857unless required by the JSON syntax or other flags.
1858
1859 JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
1860 => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
1861
1862See to L<UNICODE HANDLING ON PERLS>.
1863
1864=head2 utf8
1865
1866 $json = $json->utf8([$enable])
1867
1868 $enabled = $json->get_utf8
1869
1870If $enable is true (or missing), then the encode method will encode the JSON result
1871into UTF-8, as required by many protocols, while the decode method expects to be handled
1872an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
1873characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
1874
1875(In Perl 5.005, any character outside the range 0..255 does not exist.
1876See to L<UNICODE HANDLING ON PERLS>.)
1877
1878In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
1879encoding families, as described in RFC4627.
1880
1881If $enable is false, then the encode method will return the JSON string as a (non-encoded)
1882Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
1883(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
1884
1885Example, output UTF-16BE-encoded JSON:
1886
1887 use Encode;
1888 $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
1889
1890Example, decode UTF-32LE-encoded JSON:
1891
1892 use Encode;
1893 $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
1894
1895
1896=head2 pretty
1897
1898 $json = $json->pretty([$enable])
1899
1900This enables (or disables) all of the C<indent>, C<space_before> and
1901C<space_after> flags in one call to generate the most readable
1902(or most compact) form possible.
1903
1904Equivalent to:
1905
1906 $json->indent->space_before->space_after
1907
1908=head2 indent
1909
1910 $json = $json->indent([$enable])
1911
1912 $enabled = $json->get_indent
1913
1914The default indent space length is three.
1915You can use C<indent_length> to change the length.
1916
1917=head2 space_before
1918
1919 $json = $json->space_before([$enable])
1920
1921 $enabled = $json->get_space_before
1922
1923If C<$enable> is true (or missing), then the C<encode> method will add an extra
1924optional space before the C<:> separating keys from values in JSON objects.
1925
1926If C<$enable> is false, then the C<encode> method will not add any extra
1927space at those places.
1928
1929This setting has no effect when decoding JSON texts.
1930
1931Example, space_before enabled, space_after and indent disabled:
1932
1933 {"key" :"value"}
1934
1935=head2 space_after
1936
1937 $json = $json->space_after([$enable])
1938
1939 $enabled = $json->get_space_after
1940
1941If C<$enable> is true (or missing), then the C<encode> method will add an extra
1942optional space after the C<:> separating keys from values in JSON objects
1943and extra whitespace after the C<,> separating key-value pairs and array
1944members.
1945
1946If C<$enable> is false, then the C<encode> method will not add any extra
1947space at those places.
1948
1949This setting has no effect when decoding JSON texts.
1950
1951Example, space_before and indent disabled, space_after enabled:
1952
1953 {"key": "value"}
1954
1955=head2 relaxed
1956
1957 $json = $json->relaxed([$enable])
1958
1959 $enabled = $json->get_relaxed
1960
1961If C<$enable> is true (or missing), then C<decode> will accept some
1962extensions to normal JSON syntax (see below). C<encode> will not be
1963affected in anyway. I<Be aware that this option makes you accept invalid
1964JSON texts as if they were valid!>. I suggest only to use this option to
1965parse application-specific files written by humans (configuration files,
1966resource files etc.)
1967
1968If C<$enable> is false (the default), then C<decode> will only accept
1969valid JSON texts.
1970
1971Currently accepted extensions are:
1972
1973=over 4
1974
1975=item * list items can have an end-comma
1976
1977JSON I<separates> array elements and key-value pairs with commas. This
1978can be annoying if you write JSON texts manually and want to be able to
1979quickly append elements, so this extension accepts comma at the end of
1980such items not just between them:
1981
1982 [
1983 1,
1984 2, <- this comma not normally allowed
1985 ]
1986 {
1987 "k1": "v1",
1988 "k2": "v2", <- this comma not normally allowed
1989 }
1990
1991=item * shell-style '#'-comments
1992
1993Whenever JSON allows whitespace, shell-style comments are additionally
1994allowed. They are terminated by the first carriage-return or line-feed
1995character, after which more white-space and comments are allowed.
1996
1997 [
1998 1, # this comment not allowed in JSON
1999 # neither this one...
2000 ]
2001
2002=back
2003
2004=head2 canonical
2005
2006 $json = $json->canonical([$enable])
2007
2008 $enabled = $json->get_canonical
2009
2010If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
2011by sorting their keys. This is adding a comparatively high overhead.
2012
2013If C<$enable> is false, then the C<encode> method will output key-value
2014pairs in the order Perl stores them (which will likely change between runs
2015of the same script).
2016
2017This option is useful if you want the same data structure to be encoded as
2018the same JSON text (given the same overall settings). If it is disabled,
2019the same hash might be encoded differently even if contains the same data,
2020as key-value pairs have no inherent ordering in Perl.
2021
2022This setting has no effect when decoding JSON texts.
2023
a1e5c561 2024If you want your own sorting routine, you can give a code reference
d5424315
DG
2025or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
2026
2027=head2 allow_nonref
2028
2029 $json = $json->allow_nonref([$enable])
2030
2031 $enabled = $json->get_allow_nonref
2032
2033If C<$enable> is true (or missing), then the C<encode> method can convert a
2034non-reference into its corresponding string, number or null JSON value,
2035which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
2036values instead of croaking.
2037
2038If C<$enable> is false, then the C<encode> method will croak if it isn't
2039passed an arrayref or hashref, as JSON texts must either be an object
2040or array. Likewise, C<decode> will croak if given something that is not a
2041JSON object or array.
2042
2043 JSON::PP->new->allow_nonref->encode ("Hello, World!")
2044 => "Hello, World!"
2045
2046=head2 allow_unknown
2047
2048 $json = $json->allow_unknown ([$enable])
2049
2050 $enabled = $json->get_allow_unknown
2051
2052If $enable is true (or missing), then "encode" will *not* throw an
2053exception when it encounters values it cannot represent in JSON (for
2054example, filehandles) but instead will encode a JSON "null" value.
2055Note that blessed objects are not included here and are handled
2056separately by c<allow_nonref>.
2057
2058If $enable is false (the default), then "encode" will throw an
2059exception when it encounters anything it cannot encode as JSON.
2060
2061This option does not affect "decode" in any way, and it is
2062recommended to leave it off unless you know your communications
2063partner.
2064
2065=head2 allow_blessed
2066
2067 $json = $json->allow_blessed([$enable])
2068
2069 $enabled = $json->get_allow_blessed
2070
2071If C<$enable> is true (or missing), then the C<encode> method will not
2072barf when it encounters a blessed reference. Instead, the value of the
2073B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
2074disabled or no C<TO_JSON> method found) or a representation of the
2075object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
2076encoded. Has no effect on C<decode>.
2077
2078If C<$enable> is false (the default), then C<encode> will throw an
2079exception when it encounters a blessed object.
2080
2081=head2 convert_blessed
2082
2083 $json = $json->convert_blessed([$enable])
2084
2085 $enabled = $json->get_convert_blessed
2086
2087If C<$enable> is true (or missing), then C<encode>, upon encountering a
2088blessed object, will check for the availability of the C<TO_JSON> method
2089on the object's class. If found, it will be called in scalar context
2090and the resulting scalar will be encoded instead of the object. If no
2091C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
2092to do.
2093
2094The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
2095returns other blessed objects, those will be handled in the same
2096way. C<TO_JSON> must take care of not causing an endless recursion cycle
2097(== crash) in this case. The name of C<TO_JSON> was chosen because other
2098methods called by the Perl core (== not by the user of the object) are
2099usually in upper case letters and to avoid collisions with the C<to_json>
2100function or method.
2101
2102This setting does not yet influence C<decode> in any way.
2103
2104If C<$enable> is false, then the C<allow_blessed> setting will decide what
2105to do when a blessed object is found.
2106
2107=head2 filter_json_object
2108
2109 $json = $json->filter_json_object([$coderef])
2110
2111When C<$coderef> is specified, it will be called from C<decode> each
2112time it decodes a JSON object. The only argument passed to the coderef
2113is a reference to the newly-created hash. If the code references returns
2114a single scalar (which need not be a reference), this value
2115(i.e. a copy of that scalar to avoid aliasing) is inserted into the
2116deserialised data structure. If it returns an empty list
2117(NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
2118hash will be inserted. This setting can slow down decoding considerably.
2119
2120When C<$coderef> is omitted or undefined, any existing callback will
2121be removed and C<decode> will not change the deserialised hash in any
2122way.
2123
2124Example, convert all JSON objects into the integer 5:
2125
2126 my $js = JSON::PP->new->filter_json_object (sub { 5 });
2127 # returns [5]
2128 $js->decode ('[{}]'); # the given subroutine takes a hash reference.
2129 # throw an exception because allow_nonref is not enabled
2130 # so a lone 5 is not allowed.
2131 $js->decode ('{"a":1, "b":2}');
2132
2133=head2 filter_json_single_key_object
2134
2135 $json = $json->filter_json_single_key_object($key [=> $coderef])
2136
2137Works remotely similar to C<filter_json_object>, but is only called for
2138JSON objects having a single key named C<$key>.
2139
2140This C<$coderef> is called before the one specified via
2141C<filter_json_object>, if any. It gets passed the single value in the JSON
2142object. If it returns a single value, it will be inserted into the data
2143structure. If it returns nothing (not even C<undef> but the empty list),
2144the callback from C<filter_json_object> will be called next, as if no
2145single-key callback were specified.
2146
2147If C<$coderef> is omitted or undefined, the corresponding callback will be
2148disabled. There can only ever be one callback for a given key.
2149
2150As this callback gets called less often then the C<filter_json_object>
2151one, decoding speed will not usually suffer as much. Therefore, single-key
2152objects make excellent targets to serialise Perl objects into, especially
2153as single-key JSON objects are as close to the type-tagged value concept
2154as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
2155support this in any way, so you need to make sure your data never looks
2156like a serialised Perl hash.
2157
2158Typical names for the single object key are C<__class_whatever__>, or
2159C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
2160things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
2161with real hashes.
2162
2163Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
2164into the corresponding C<< $WIDGET{<id>} >> object:
2165
2166 # return whatever is in $WIDGET{5}:
2167 JSON::PP
2168 ->new
2169 ->filter_json_single_key_object (__widget__ => sub {
2170 $WIDGET{ $_[0] }
2171 })
2172 ->decode ('{"__widget__": 5')
2173
2174 # this can be used with a TO_JSON method in some "widget" class
2175 # for serialisation to json:
2176 sub WidgetBase::TO_JSON {
2177 my ($self) = @_;
2178
2179 unless ($self->{id}) {
2180 $self->{id} = ..get..some..id..;
2181 $WIDGET{$self->{id}} = $self;
2182 }
2183
2184 { __widget__ => $self->{id} }
2185 }
2186
2187=head2 shrink
2188
2189 $json = $json->shrink([$enable])
2190
2191 $enabled = $json->get_shrink
2192
2193In JSON::XS, this flag resizes strings generated by either
2194C<encode> or C<decode> to their minimum size possible.
2195It will also try to downgrade any strings to octet-form if possible.
2196
2197In JSON::PP, it is noop about resizing strings but tries
2198C<utf8::downgrade> to the returned string by C<encode>.
2199See to L<utf8>.
2200
2201See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
2202
2203=head2 max_depth
2204
2205 $json = $json->max_depth([$maximum_nesting_depth])
2206
2207 $max_depth = $json->get_max_depth
2208
2209Sets the maximum nesting level (default C<512>) accepted while encoding
2210or decoding. If a higher nesting level is detected in JSON text or a Perl
2211data structure, then the encoder and decoder will stop and croak at that
2212point.
2213
2214Nesting level is defined by number of hash- or arrayrefs that the encoder
2215needs to traverse to reach a given point or the number of C<{> or C<[>
2216characters without their matching closing parenthesis crossed to reach a
2217given character in a string.
2218
2219If no argument is given, the highest possible setting will be used, which
2220is rarely useful.
2221
a1e5c561 2222See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
d5424315
DG
2223
2224When a large value (100 or more) was set and it de/encodes a deep nested object/text,
a1e5c561 2225it may raise a warning 'Deep recursion on subroutine' at the perl runtime phase.
d5424315
DG
2226
2227=head2 max_size
2228
2229 $json = $json->max_size([$maximum_string_size])
2230
2231 $max_size = $json->get_max_size
2232
2233Set the maximum length a JSON text may have (in bytes) where decoding is
2234being attempted. The default is C<0>, meaning no limit. When C<decode>
2235is called on a string that is longer then this many bytes, it will not
2236attempt to decode the string but throw an exception. This setting has no
2237effect on C<encode> (yet).
2238
2239If no argument is given, the limit check will be deactivated (same as when
2240C<0> is specified).
2241
a1e5c561 2242See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
d5424315
DG
2243
2244=head2 encode
2245
2246 $json_text = $json->encode($perl_scalar)
2247
2248Converts the given Perl data structure (a simple scalar or a reference
2249to a hash or array) to its JSON representation. Simple scalars will be
2250converted into JSON string or number sequences, while references to arrays
2251become JSON arrays and references to hashes become JSON objects. Undefined
2252Perl values (e.g. C<undef>) become JSON C<null> values.
2253References to the integers C<0> and C<1> are converted into C<true> and C<false>.
2254
2255=head2 decode
2256
2257 $perl_scalar = $json->decode($json_text)
2258
2259The opposite of C<encode>: expects a JSON text and tries to parse it,
2260returning the resulting simple scalar or reference. Croaks on error.
2261
2262JSON numbers and strings become simple Perl scalars. JSON arrays become
2263Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
2264C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
2265C<null> becomes C<undef>.
2266
2267=head2 decode_prefix
2268
2269 ($perl_scalar, $characters) = $json->decode_prefix($json_text)
2270
2271This works like the C<decode> method, but instead of raising an exception
2272when there is trailing garbage after the first JSON object, it will
2273silently stop parsing there and return the number of characters consumed
2274so far.
2275
2276 JSON->new->decode_prefix ("[1] the tail")
2277 => ([], 3)
2278
2279=head1 INCREMENTAL PARSING
2280
2281Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
2282
2283In some cases, there is the need for incremental parsing of JSON texts.
2284This module does allow you to parse a JSON stream incrementally.
2285It does so by accumulating text until it has a full JSON object, which
2286it then can decode. This process is similar to using C<decode_prefix>
2287to see if a full JSON object is available, but is much more efficient
2288(and can be implemented with a minimum of method calls).
2289
2290This module will only attempt to parse the JSON text once it is sure it
2291has enough text to get a decisive result, using a very simple but
2292truly incremental parser. This means that it sometimes won't stop as
a1e5c561 2293early as the full parser, for example, it doesn't detect parentheses
d5424315
DG
2294mismatches. The only thing it guarantees is that it starts decoding as
2295soon as a syntactically valid JSON text has been seen. This means you need
2296to set resource limits (e.g. C<max_size>) to ensure the parser will stop
2297parsing in the presence if syntax errors.
2298
2299The following methods implement this incremental parser.
2300
2301=head2 incr_parse
2302
2303 $json->incr_parse( [$string] ) # void context
2304
2305 $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
2306
2307 @obj_or_empty = $json->incr_parse( [$string] ) # list context
2308
2309This is the central parsing function. It can both append new text and
2310extract objects from the stream accumulated so far (both of these
2311functions are optional).
2312
2313If C<$string> is given, then this string is appended to the already
2314existing JSON fragment stored in the C<$json> object.
2315
2316After that, if the function is called in void context, it will simply
2317return without doing anything further. This can be used to add more text
2318in as many chunks as you want.
2319
2320If the method is called in scalar context, then it will try to extract
2321exactly I<one> JSON object. If that is successful, it will return this
2322object, otherwise it will return C<undef>. If there is a parse error,
2323this method will croak just as C<decode> would do (one can then use
a1e5c561 2324C<incr_skip> to skip the erroneous part). This is the most common way of
d5424315
DG
2325using the method.
2326
2327And finally, in list context, it will try to extract as many objects
2328from the stream as it can find and return them, or the empty list
2329otherwise. For this to work, there must be no separators between the JSON
2330objects or arrays, instead they must be concatenated back-to-back. If
2331an error occurs, an exception will be raised as in the scalar context
2332case. Note that in this case, any previously-parsed JSON texts will be
2333lost.
2334
2335Example: Parse some JSON arrays/objects in a given string and return them.
2336
2337 my @objs = JSON->new->incr_parse ("[5][7][1,2]");
2338
2339=head2 incr_text
2340
2341 $lvalue_string = $json->incr_text
2342
2343This method returns the currently stored JSON fragment as an lvalue, that
2344is, you can manipulate it. This I<only> works when a preceding call to
2345C<incr_parse> in I<scalar context> successfully returned an object. Under
2346all other circumstances you must not call this function (I mean it.
2347although in simple tests it might actually work, it I<will> fail under
2348real world conditions). As a special exception, you can also call this
2349method before having parsed anything.
2350
2351This function is useful in two cases: a) finding the trailing text after a
2352JSON object or b) parsing multiple JSON objects separated by non-JSON text
2353(such as commas).
2354
2355 $json->incr_text =~ s/\s*,\s*//;
2356
2357In Perl 5.005, C<lvalue> attribute is not available.
2358You must write codes like the below:
2359
2360 $string = $json->incr_text;
2361 $string =~ s/\s*,\s*//;
2362 $json->incr_text( $string );
2363
2364=head2 incr_skip
2365
2366 $json->incr_skip
2367
2368This will reset the state of the incremental parser and will remove the
2369parsed text from the input buffer. This is useful after C<incr_parse>
2370died, in which case the input buffer and incremental parser state is left
2371unchanged, to skip the text parsed so far and to reset the parse state.
2372
2373=head2 incr_reset
2374
2375 $json->incr_reset
2376
2377This completely resets the incremental parser, that is, after this call,
2378it will be as if the parser had never parsed anything.
2379
a1e5c561 2380This is useful if you want to repeatedly parse JSON objects and want to
d5424315
DG
2381ignore any trailing data, which means you have to reset the parser after
2382each successful decode.
2383
2384See to L<JSON::XS/INCREMENTAL PARSING> for examples.
2385
2386
2387=head1 JSON::PP OWN METHODS
2388
2389=head2 allow_singlequote
2390
2391 $json = $json->allow_singlequote([$enable])
2392
2393If C<$enable> is true (or missing), then C<decode> will accept
2394JSON strings quoted by single quotations that are invalid JSON
2395format.
2396
2397 $json->allow_singlequote->decode({"foo":'bar'});
2398 $json->allow_singlequote->decode({'foo':"bar"});
2399 $json->allow_singlequote->decode({'foo':'bar'});
2400
2401As same as the C<relaxed> option, this option may be used to parse
2402application-specific files written by humans.
2403
2404
2405=head2 allow_barekey
2406
2407 $json = $json->allow_barekey([$enable])
2408
2409If C<$enable> is true (or missing), then C<decode> will accept
2410bare keys of JSON object that are invalid JSON format.
2411
2412As same as the C<relaxed> option, this option may be used to parse
2413application-specific files written by humans.
2414
2415 $json->allow_barekey->decode('{foo:"bar"}');
2416
2417=head2 allow_bignum
2418
2419 $json = $json->allow_bignum([$enable])
2420
2421If C<$enable> is true (or missing), then C<decode> will convert
2422the big integer Perl cannot handle as integer into a L<Math::BigInt>
2423object and convert a floating number (any) into a L<Math::BigFloat>.
2424
a1e5c561
CBW
2425On the contrary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
2426objects into JSON numbers with C<allow_blessed> enabled.
d5424315
DG
2427
2428 $json->allow_nonref->allow_blessed->allow_bignum;
2429 $bigfloat = $json->decode('2.000000000000000000000000001');
2430 print $json->encode($bigfloat);
2431 # => 2.000000000000000000000000001
2432
a1e5c561 2433See to L<JSON::XS/MAPPING> about the normal conversion of JSON number.
d5424315
DG
2434
2435=head2 loose
2436
2437 $json = $json->loose([$enable])
2438
2439The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
a1e5c561 2440and the module doesn't allow you to C<decode> to these (except for \x2f).
d5424315
DG
2441If C<$enable> is true (or missing), then C<decode> will accept these
2442unescaped strings.
2443
2444 $json->loose->decode(qq|["abc
2445 def"]|);
2446
a1e5c561 2447See L<JSON::XS/SECURITY CONSIDERATIONS>.
d5424315
DG
2448
2449=head2 escape_slash
2450
2451 $json = $json->escape_slash([$enable])
2452
2453According to JSON Grammar, I<slash> (U+002F) is escaped. But default
2454JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
2455
2456If C<$enable> is true (or missing), then C<encode> will escape slashes.
2457
2458=head2 indent_length
2459
2460 $json = $json->indent_length($length)
2461
2462JSON::XS indent space length is 3 and cannot be changed.
2463JSON::PP set the indent space length with the given $length.
2464The default is 3. The acceptable range is 0 to 15.
2465
2466=head2 sort_by
2467
2468 $json = $json->sort_by($function_name)
2469 $json = $json->sort_by($subroutine_ref)
2470
2471If $function_name or $subroutine_ref are set, its sort routine are used
2472in encoding JSON objects.
2473
2474 $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
2475 # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2476
2477 $js = $pc->sort_by('own_sort')->encode($obj);
2478 # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2479
2480 sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
2481
2482As the sorting routine runs in the JSON::PP scope, the given
2483subroutine name and the special variables C<$a>, C<$b> will begin
2484'JSON::PP::'.
2485
2486If $integer is set, then the effect is same as C<canonical> on.
2487
2488=head1 INTERNAL
2489
2490For developers.
2491
2492=over
2493
2494=item PP_encode_box
2495
2496Returns
2497
2498 {
2499 depth => $depth,
2500 indent_count => $indent_count,
2501 }
2502
2503
2504=item PP_decode_box
2505
2506Returns
2507
2508 {
2509 text => $text,
2510 at => $at,
2511 ch => $ch,
2512 len => $len,
2513 depth => $depth,
2514 encoding => $encoding,
2515 is_valid_utf8 => $is_valid_utf8,
2516 };
2517
2518=back
2519
2520=head1 MAPPING
2521
2522This section is copied from JSON::XS and modified to C<JSON::PP>.
2523JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
2524
2525See to L<JSON::XS/MAPPING>.
2526
2527=head2 JSON -> PERL
2528
2529=over 4
2530
2531=item object
2532
2533A JSON object becomes a reference to a hash in Perl. No ordering of object
2534keys is preserved (JSON does not preserver object key ordering itself).
2535
2536=item array
2537
2538A JSON array becomes a reference to an array in Perl.
2539
2540=item string
2541
2542A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
2543are represented by the same codepoints in the Perl string, so no manual
2544decoding is necessary.
2545
2546=item number
2547
2548A JSON number becomes either an integer, numeric (floating point) or
2549string scalar in perl, depending on its range and any fractional parts. On
2550the Perl level, there is no difference between those as Perl handles all
2551the conversion details, but an integer may take slightly less memory and
2552might represent more values exactly than floating point numbers.
2553
2554If the number consists of digits only, C<JSON> will try to represent
2555it as an integer value. If that fails, it will try to represent it as
2556a numeric (floating point) value if that is possible without loss of
2557precision. Otherwise it will preserve the number as a string value (in
2558which case you lose roundtripping ability, as the JSON number will be
a1e5c561 2559re-encoded to a JSON string).
d5424315
DG
2560
2561Numbers containing a fractional or exponential part will always be
2562represented as numeric (floating point) values, possibly at a loss of
2563precision (in which case you might lose perfect roundtripping ability, but
2564the JSON number will still be re-encoded as a JSON number).
2565
2566Note that precision is not accuracy - binary floating point values cannot
2567represent most decimal fractions exactly, and when converting from and to
2568floating point, C<JSON> only guarantees precision up to but not including
a1e5c561 2569the least significant bit.
d5424315 2570
a1e5c561 2571When C<allow_bignum> is enabled, the big integers
d5424315
DG
2572and the numeric can be optionally converted into L<Math::BigInt> and
2573L<Math::BigFloat> objects.
2574
2575=item true, false
2576
2577These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
2578respectively. They are overloaded to act almost exactly like the numbers
a1e5c561 2579C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
d5424315
DG
2580the C<JSON::is_bool> function.
2581
2582 print JSON::PP::true . "\n";
2583 => true
2584 print JSON::PP::true + 1;
2585 => 1
2586
2587 ok(JSON::true eq '1');
2588 ok(JSON::true == 1);
2589
2590C<JSON> will install these missing overloading features to the backend modules.
2591
2592
2593=item null
2594
2595A JSON null atom becomes C<undef> in Perl.
2596
a1e5c561 2597C<JSON::PP::null> returns C<undef>.
d5424315
DG
2598
2599=back
2600
2601
2602=head2 PERL -> JSON
2603
2604The mapping from Perl to JSON is slightly more difficult, as Perl is a
2605truly typeless language, so we can only guess which JSON type is meant by
2606a Perl value.
2607
2608=over 4
2609
2610=item hash references
2611
2612Perl hash references become JSON objects. As there is no inherent ordering
2613in hash keys (or JSON objects), they will usually be encoded in a
2614pseudo-random order that can change between runs of the same program but
2615stays generally the same within a single run of a program. C<JSON>
2616optionally sort the hash keys (determined by the I<canonical> flag), so
2617the same datastructure will serialise to the same JSON text (given same
2618settings and version of JSON::XS), but this incurs a runtime overhead
2619and is only rarely useful, e.g. when you want to compare some JSON text
2620against another for equality.
2621
2622
2623=item array references
2624
2625Perl array references become JSON arrays.
2626
2627=item other references
2628
2629Other unblessed references are generally not allowed and will cause an
2630exception to be thrown, except for references to the integers C<0> and
2631C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
2632also use C<JSON::false> and C<JSON::true> to improve readability.
2633
2634 to_json [\0,JSON::PP::true] # yields [false,true]
2635
2636=item JSON::PP::true, JSON::PP::false, JSON::PP::null
2637
2638These special values become JSON true and JSON false values,
2639respectively. You can also use C<\1> and C<\0> directly if you want.
2640
2641JSON::PP::null returns C<undef>.
2642
2643=item blessed objects
2644
2645Blessed objects are not directly representable in JSON. See the
2646C<allow_blessed> and C<convert_blessed> methods on various options on
2647how to deal with this: basically, you can choose between throwing an
2648exception, encoding the reference as if it weren't blessed, or provide
2649your own serialiser method.
2650
2651See to L<convert_blessed>.
2652
2653=item simple scalars
2654
2655Simple Perl scalars (any scalar that is not a reference) are the most
2656difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
2657JSON C<null> values, scalars that have last been used in a string context
2658before encoding as JSON strings, and anything else as number value:
2659
2660 # dump as number
2661 encode_json [2] # yields [2]
2662 encode_json [-3.0e17] # yields [-3e+17]
2663 my $value = 5; encode_json [$value] # yields [5]
2664
2665 # used as string, so dump as string
2666 print $value;
2667 encode_json [$value] # yields ["5"]
2668
2669 # undef becomes null
2670 encode_json [undef] # yields [null]
2671
2672You can force the type to be a string by stringifying it:
2673
2674 my $x = 3.1; # some variable containing a number
2675 "$x"; # stringified
2676 $x .= ""; # another, more awkward way to stringify
2677 print $x; # perl does it for you, too, quite often
2678
2679You can force the type to be a number by numifying it:
2680
2681 my $x = "3"; # some variable containing a string
2682 $x += 0; # numify it, ensuring it will be dumped as a number
a1e5c561 2683 $x *= 1; # same thing, the choice is yours.
d5424315 2684
a1e5c561 2685You cannot currently force the type in other, less obscure, ways.
d5424315
DG
2686
2687Note that numerical precision has the same meaning as under Perl (so
2688binary to decimal conversion follows the same rules as in Perl, which
2689can differ to other languages). Also, your perl interpreter might expose
2690extensions to the floating point numbers of your platform, such as
2691infinities or NaN's - these cannot be represented in JSON, and it is an
2692error to pass those in.
2693
2694=item Big Number
2695
a1e5c561 2696When C<allow_bignum> is enabled,
d5424315
DG
2697C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
2698objects into JSON numbers.
2699
2700
2701=back
2702
2703=head1 UNICODE HANDLING ON PERLS
2704
2705If you do not know about Unicode on Perl well,
2706please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
2707
2708=head2 Perl 5.8 and later
2709
2710Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
2711
2712 $json->allow_nonref->encode(chr hex 3042);
2713 $json->allow_nonref->encode(chr hex 12345);
2714
a1e5c561 2715Returns C<"\u3042"> and C<"\ud808\udf45"> respectively.
d5424315
DG
2716
2717 $json->allow_nonref->decode('"\u3042"');
2718 $json->allow_nonref->decode('"\ud808\udf45"');
2719
2720Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
2721
2722Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
2723so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
2724
2725
2726=head2 Perl 5.6
2727
2728Perl can handle Unicode and the JSON::PP de/encode methods also work.
2729
2730=head2 Perl 5.005
2731
a1e5c561 2732Perl 5.005 is a byte semantics world -- all strings are sequences of bytes.
d5424315
DG
2733That means the unicode handling is not available.
2734
2735In encoding,
2736
2737 $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
2738 $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
2739
2740Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
2741as C<$value % 256>, so the above codes are equivalent to :
2742
2743 $json->allow_nonref->encode(chr 66);
2744 $json->allow_nonref->encode(chr 69);
2745
2746In decoding,
2747
2748 $json->decode('"\u00e3\u0081\u0082"');
2749
2750The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
a1e5c561 2751Japanese character (C<HIRAGANA LETTER A>).
d5424315
DG
2752And if it is represented in Unicode code point, C<U+3042>.
2753
2754Next,
2755
2756 $json->decode('"\u3042"');
2757
2758We ordinary expect the returned value is a Unicode character C<U+3042>.
2759But here is 5.005 world. This is C<0xE3 0x81 0x82>.
2760
2761 $json->decode('"\ud808\udf45"');
2762
2763This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
2764
2765
2766=head1 TODO
2767
2768=over
2769
2770=item speed
2771
2772=item memory saving
2773
2774=back
2775
2776
2777=head1 SEE ALSO
2778
2779Most of the document are copied and modified from JSON::XS doc.
2780
2781L<JSON::XS>
2782
2783RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
2784
2785=head1 AUTHOR
2786
2787Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
2788
2789
2790=head1 COPYRIGHT AND LICENSE
2791
a1e5c561 2792Copyright 2007-2016 by Makamaka Hannyaharamitu
d5424315
DG
2793
2794This library is free software; you can redistribute it and/or modify
2795it under the same terms as Perl itself.
2796
2797=cut