xref: /openbsd-src/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP.pm (revision c90a81c56dcebd6a1b73fe4aff9b03385b8e63b3)
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
14$JSON::PP::VERSION = '2.27300_01';
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
55    # Perl version check, Unicode handling is enable?
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();
325                    if ( defined $result and ref( $result ) ) {
326                        if ( refaddr( $obj ) eq refaddr( $result ) ) {
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
611    my $ch;   # 1chracter
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
620    my $max_depth;      # max nest nubmer of objects and arrays
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 );
658            utf8::encode( $text );
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 ) {
810                        unless( $ch = is_valid_utf8($ch) ) {
811                            $at -= 1;
812                            decode_error("malformed UTF-8 character in JSON string");
813                        }
814                        else {
815                            $at += $utf8_len - 1;
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 {
888        my $a  = $_[0] || []; # you can use this code to use another array ref object.
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 {
938        my $o = $_[0] || {}; # you can use this code to use another hash ref object.
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;
1048
1049        # According to RFC4627, hex or oct digts are invalid.
1050        if($ch eq '0'){
1051            my $peek = substr($text,$at,1);
1052            my $hex  = $peek =~ /[xX]/; # 0 or 1
1053
1054            if($hex){
1055                decode_error("malformed number (leading zero must not be followed by another digit)");
1056                ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
1057            }
1058            else{ # oct
1059                ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
1060                if (defined $n and length $n > 1) {
1061                    decode_error("malformed number (leading zero must not be followed by another digit)");
1062                }
1063            }
1064
1065            if(defined $n and length($n)){
1066                if (!$hex and length($n) == 1) {
1067                   decode_error("malformed number (leading zero must not be followed by another digit)");
1068                }
1069                $at += length($n) + $hex;
1070                next_chr;
1071                return $hex ? hex($n) : oct($n);
1072            }
1073        }
1074
1075        if($ch eq '-'){
1076            $n = '-';
1077            next_chr;
1078            if (!defined $ch or $ch !~ /\d/) {
1079                decode_error("malformed number (no digits after initial minus)");
1080            }
1081        }
1082
1083        while(defined $ch and $ch =~ /\d/){
1084            $n .= $ch;
1085            next_chr;
1086        }
1087
1088        if(defined $ch and $ch eq '.'){
1089            $n .= '.';
1090
1091            next_chr;
1092            if (!defined $ch or $ch !~ /\d/) {
1093                decode_error("malformed number (no digits after decimal point)");
1094            }
1095            else {
1096                $n .= $ch;
1097            }
1098
1099            while(defined(next_chr) and $ch =~ /\d/){
1100                $n .= $ch;
1101            }
1102        }
1103
1104        if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
1105            $n .= $ch;
1106            next_chr;
1107
1108            if(defined($ch) and ($ch eq '+' or $ch eq '-')){
1109                $n .= $ch;
1110                next_chr;
1111                if (!defined $ch or $ch =~ /\D/) {
1112                    decode_error("malformed number (no digits after exp sign)");
1113                }
1114                $n .= $ch;
1115            }
1116            elsif(defined($ch) and $ch =~ /\d/){
1117                $n .= $ch;
1118            }
1119            else {
1120                decode_error("malformed number (no digits after exp sign)");
1121            }
1122
1123            while(defined(next_chr) and $ch =~ /\d/){
1124                $n .= $ch;
1125            }
1126
1127        }
1128
1129        $v .= $n;
1130
1131        if ($v !~ /[.eE]/ and length $v > $max_intsize) {
1132            if ($allow_bigint) { # from Adam Sussman
1133                require Math::BigInt;
1134                return Math::BigInt->new($v);
1135            }
1136            else {
1137                return "$v";
1138            }
1139        }
1140        elsif ($allow_bigint) {
1141            require Math::BigFloat;
1142            return Math::BigFloat->new($v);
1143        }
1144
1145        return 0+$v;
1146    }
1147
1148
1149    sub is_valid_utf8 {
1150
1151        $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
1152                  : $_[0] =~ /[\xC2-\xDF]/  ? 2
1153                  : $_[0] =~ /[\xE0-\xEF]/  ? 3
1154                  : $_[0] =~ /[\xF0-\xF4]/  ? 4
1155                  : 0
1156                  ;
1157
1158        return unless $utf8_len;
1159
1160        my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
1161
1162        return ( $is_valid_utf8 =~ /^(?:
1163             [\x00-\x7F]
1164            |[\xC2-\xDF][\x80-\xBF]
1165            |[\xE0][\xA0-\xBF][\x80-\xBF]
1166            |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
1167            |[\xED][\x80-\x9F][\x80-\xBF]
1168            |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
1169            |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
1170            |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
1171            |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
1172        )$/x )  ? $is_valid_utf8 : '';
1173    }
1174
1175
1176    sub decode_error {
1177        my $error  = shift;
1178        my $no_rep = shift;
1179        my $str    = defined $text ? substr($text, $at) : '';
1180        my $mess   = '';
1181        my $type   = $] >= 5.008           ? 'U*'
1182                   : $] <  5.006           ? 'C*'
1183                   : utf8::is_utf8( $str ) ? 'U*' # 5.6
1184                   : 'C*'
1185                   ;
1186
1187        for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
1188            $mess .=  $c == 0x07 ? '\a'
1189                    : $c == 0x09 ? '\t'
1190                    : $c == 0x0a ? '\n'
1191                    : $c == 0x0d ? '\r'
1192                    : $c == 0x0c ? '\f'
1193                    : $c <  0x20 ? sprintf('\x{%x}', $c)
1194                    : $c == 0x5c ? '\\\\'
1195                    : $c <  0x80 ? chr($c)
1196                    : sprintf('\x{%x}', $c)
1197                    ;
1198            if ( length $mess >= 20 ) {
1199                $mess .= '...';
1200                last;
1201            }
1202        }
1203
1204        unless ( length $mess ) {
1205            $mess = '(end of string)';
1206        }
1207
1208        Carp::croak (
1209            $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
1210        );
1211
1212    }
1213
1214
1215    sub _json_object_hook {
1216        my $o    = $_[0];
1217        my @ks = keys %{$o};
1218
1219        if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
1220            my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
1221            if (@val == 1) {
1222                return $val[0];
1223            }
1224        }
1225
1226        my @val = $cb_object->($o) if ($cb_object);
1227        if (@val == 0 or @val > 1) {
1228            return $o;
1229        }
1230        else {
1231            return $val[0];
1232        }
1233    }
1234
1235
1236    sub PP_decode_box {
1237        {
1238            text    => $text,
1239            at      => $at,
1240            ch      => $ch,
1241            len     => $len,
1242            depth   => $depth,
1243            encoding      => $encoding,
1244            is_valid_utf8 => $is_valid_utf8,
1245        };
1246    }
1247
1248} # PARSE
1249
1250
1251sub _decode_surrogates { # from perlunicode
1252    my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
1253    my $un  = pack('U*', $uni);
1254    utf8::encode( $un );
1255    return $un;
1256}
1257
1258
1259sub _decode_unicode {
1260    my $un = pack('U', hex shift);
1261    utf8::encode( $un );
1262    return $un;
1263}
1264
1265#
1266# Setup for various Perl versions (the code from JSON::PP58)
1267#
1268
1269BEGIN {
1270
1271    unless ( defined &utf8::is_utf8 ) {
1272       require Encode;
1273       *utf8::is_utf8 = *Encode::is_utf8;
1274    }
1275
1276    if ( $] >= 5.008 ) {
1277        *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
1278        *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
1279        *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
1280        *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
1281    }
1282
1283    if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
1284        package JSON::PP;
1285        require subs;
1286        subs->import('join');
1287        eval q|
1288            sub join {
1289                return '' if (@_ < 2);
1290                my $j   = shift;
1291                my $str = shift;
1292                for (@_) { $str .= $j . $_; }
1293                return $str;
1294            }
1295        |;
1296    }
1297
1298
1299    sub JSON::PP::incr_parse {
1300        local $Carp::CarpLevel = 1;
1301        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
1302    }
1303
1304
1305    sub JSON::PP::incr_skip {
1306        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
1307    }
1308
1309
1310    sub JSON::PP::incr_reset {
1311        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
1312    }
1313
1314    eval q{
1315        sub JSON::PP::incr_text : lvalue {
1316            $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
1317
1318            if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
1319                Carp::croak("incr_text can not be called when the incremental parser already started parsing");
1320            }
1321            $_[0]->{_incr_parser}->{incr_text};
1322        }
1323    } if ( $] >= 5.006 );
1324
1325} # Setup for various Perl versions (the code from JSON::PP58)
1326
1327
1328###############################
1329# Utilities
1330#
1331
1332BEGIN {
1333    eval 'require Scalar::Util';
1334    unless($@){
1335        *JSON::PP::blessed = \&Scalar::Util::blessed;
1336        *JSON::PP::reftype = \&Scalar::Util::reftype;
1337        *JSON::PP::refaddr = \&Scalar::Util::refaddr;
1338    }
1339    else{ # This code is from Sclar::Util.
1340        # warn $@;
1341        eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
1342        *JSON::PP::blessed = sub {
1343            local($@, $SIG{__DIE__}, $SIG{__WARN__});
1344            ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
1345        };
1346        my %tmap = qw(
1347            B::NULL   SCALAR
1348            B::HV     HASH
1349            B::AV     ARRAY
1350            B::CV     CODE
1351            B::IO     IO
1352            B::GV     GLOB
1353            B::REGEXP REGEXP
1354        );
1355        *JSON::PP::reftype = sub {
1356            my $r = shift;
1357
1358            return undef unless length(ref($r));
1359
1360            my $t = ref(B::svref_2object($r));
1361
1362            return
1363                exists $tmap{$t} ? $tmap{$t}
1364              : length(ref($$r)) ? 'REF'
1365              :                    'SCALAR';
1366        };
1367        *JSON::PP::refaddr = sub {
1368          return undef unless length(ref($_[0]));
1369
1370          my $addr;
1371          if(defined(my $pkg = blessed($_[0]))) {
1372            $addr .= bless $_[0], 'Scalar::Util::Fake';
1373            bless $_[0], $pkg;
1374          }
1375          else {
1376            $addr .= $_[0]
1377          }
1378
1379          $addr =~ /0x(\w+)/;
1380          local $^W;
1381          #no warnings 'portable';
1382          hex($1);
1383        }
1384    }
1385}
1386
1387
1388# shamely copied and modified from JSON::XS code.
1389
1390$JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
1391$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1392
1393sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
1394
1395sub true  { $JSON::PP::true  }
1396sub false { $JSON::PP::false }
1397sub null  { undef; }
1398
1399###############################
1400
1401package JSON::PP::Boolean;
1402
1403use overload (
1404   "0+"     => sub { ${$_[0]} },
1405   "++"     => sub { $_[0] = ${$_[0]} + 1 },
1406   "--"     => sub { $_[0] = ${$_[0]} - 1 },
1407   fallback => 1,
1408);
1409
1410
1411###############################
1412
1413package JSON::PP::IncrParser;
1414
1415use strict;
1416
1417use constant INCR_M_WS   => 0; # initial whitespace skipping
1418use constant INCR_M_STR  => 1; # inside string
1419use constant INCR_M_BS   => 2; # inside backslash
1420use constant INCR_M_JSON => 3; # outside anything, count nesting
1421use constant INCR_M_C0   => 4;
1422use constant INCR_M_C1   => 5;
1423
1424$JSON::PP::IncrParser::VERSION = '1.01';
1425
1426my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
1427
1428sub new {
1429    my ( $class ) = @_;
1430
1431    bless {
1432        incr_nest    => 0,
1433        incr_text    => undef,
1434        incr_parsing => 0,
1435        incr_p       => 0,
1436    }, $class;
1437}
1438
1439
1440sub incr_parse {
1441    my ( $self, $coder, $text ) = @_;
1442
1443    $self->{incr_text} = '' unless ( defined $self->{incr_text} );
1444
1445    if ( defined $text ) {
1446        if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
1447            utf8::upgrade( $self->{incr_text} ) ;
1448            utf8::decode( $self->{incr_text} ) ;
1449        }
1450        $self->{incr_text} .= $text;
1451    }
1452
1453
1454    my $max_size = $coder->get_max_size;
1455
1456    if ( defined wantarray ) {
1457
1458        $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
1459
1460        if ( wantarray ) {
1461            my @ret;
1462
1463            $self->{incr_parsing} = 1;
1464
1465            do {
1466                push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
1467
1468                unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
1469                    $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
1470                }
1471
1472            } until ( length $self->{incr_text} >= $self->{incr_p} );
1473
1474            $self->{incr_parsing} = 0;
1475
1476            return @ret;
1477        }
1478        else { # in scalar context
1479            $self->{incr_parsing} = 1;
1480            my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
1481            $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
1482            return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
1483        }
1484
1485    }
1486
1487}
1488
1489
1490sub _incr_parse {
1491    my ( $self, $coder, $text, $skip ) = @_;
1492    my $p = $self->{incr_p};
1493    my $restore = $p;
1494
1495    my @obj;
1496    my $len = length $text;
1497
1498    if ( $self->{incr_mode} == INCR_M_WS ) {
1499        while ( $len > $p ) {
1500            my $s = substr( $text, $p, 1 );
1501            $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
1502            $self->{incr_mode} = INCR_M_JSON;
1503            last;
1504       }
1505    }
1506
1507    while ( $len > $p ) {
1508        my $s = substr( $text, $p++, 1 );
1509
1510        if ( $s eq '"' ) {
1511            if (substr( $text, $p - 2, 1 ) eq '\\' ) {
1512                next;
1513            }
1514
1515            if ( $self->{incr_mode} != INCR_M_STR  ) {
1516                $self->{incr_mode} = INCR_M_STR;
1517            }
1518            else {
1519                $self->{incr_mode} = INCR_M_JSON;
1520                unless ( $self->{incr_nest} ) {
1521                    last;
1522                }
1523            }
1524        }
1525
1526        if ( $self->{incr_mode} == INCR_M_JSON ) {
1527
1528            if ( $s eq '[' or $s eq '{' ) {
1529                if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
1530                    Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
1531                }
1532            }
1533            elsif ( $s eq ']' or $s eq '}' ) {
1534                last if ( --$self->{incr_nest} <= 0 );
1535            }
1536            elsif ( $s eq '#' ) {
1537                while ( $len > $p ) {
1538                    last if substr( $text, $p++, 1 ) eq "\n";
1539                }
1540            }
1541
1542        }
1543
1544    }
1545
1546    $self->{incr_p} = $p;
1547
1548    return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
1549    return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
1550
1551    return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
1552
1553    local $Carp::CarpLevel = 2;
1554
1555    $self->{incr_p} = $restore;
1556    $self->{incr_c} = $p;
1557
1558    my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
1559
1560    $self->{incr_text} = substr( $self->{incr_text}, $p );
1561    $self->{incr_p} = 0;
1562
1563    return $obj || '';
1564}
1565
1566
1567sub incr_text {
1568    if ( $_[0]->{incr_parsing} ) {
1569        Carp::croak("incr_text can not be called when the incremental parser already started parsing");
1570    }
1571    $_[0]->{incr_text};
1572}
1573
1574
1575sub incr_skip {
1576    my $self  = shift;
1577    $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
1578    $self->{incr_p} = 0;
1579}
1580
1581
1582sub incr_reset {
1583    my $self = shift;
1584    $self->{incr_text}    = undef;
1585    $self->{incr_p}       = 0;
1586    $self->{incr_mode}    = 0;
1587    $self->{incr_nest}    = 0;
1588    $self->{incr_parsing} = 0;
1589}
1590
1591###############################
1592
1593
15941;
1595__END__
1596=pod
1597
1598=head1 NAME
1599
1600JSON::PP - JSON::XS compatible pure-Perl module.
1601
1602=head1 SYNOPSIS
1603
1604 use JSON::PP;
1605
1606 # exported functions, they croak on error
1607 # and expect/generate UTF-8
1608
1609 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
1610 $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
1611
1612 # OO-interface
1613
1614 $coder = JSON::PP->new->ascii->pretty->allow_nonref;
1615
1616 $json_text   = $json->encode( $perl_scalar );
1617 $perl_scalar = $json->decode( $json_text );
1618
1619 $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
1620
1621 # Note that JSON version 2.0 and above will automatically use
1622 # JSON::XS or JSON::PP, so you should be able to just:
1623
1624 use JSON;
1625
1626
1627=head1 VERSION
1628
1629    2.27300
1630
1631L<JSON::XS> 2.27 (~2.30) compatible.
1632
1633=head1 NOTE
1634
1635JSON::PP had been inculded in JSON distribution (CPAN module).
1636It was a perl core module in Perl 5.14.
1637
1638=head1 DESCRIPTION
1639
1640This module is L<JSON::XS> compatible pure Perl module.
1641(Perl 5.8 or later is recommended)
1642
1643JSON::XS is the fastest and most proper JSON module on CPAN.
1644It is written by Marc Lehmann in C, so must be compiled and
1645installed in the used environment.
1646
1647JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
1648
1649
1650=head2 FEATURES
1651
1652=over
1653
1654=item * correct unicode handling
1655
1656This module knows how to handle Unicode (depending on Perl version).
1657
1658See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
1659
1660
1661=item * round-trip integrity
1662
1663When you serialise a perl data structure using only data types supported
1664by JSON and Perl, the deserialised data structure is identical on the Perl
1665level. (e.g. the string "2.0" doesn't suddenly become "2" just because
1666it looks like a number). There I<are> minor exceptions to this, read the
1667MAPPING section below to learn about those.
1668
1669
1670=item * strict checking of JSON correctness
1671
1672There is no guessing, no generating of illegal JSON texts by default,
1673and only JSON is accepted as input by default (the latter is a security feature).
1674But when some options are set, loose chcking features are available.
1675
1676=back
1677
1678=head1 FUNCTIONAL INTERFACE
1679
1680Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
1681
1682=head2 encode_json
1683
1684    $json_text = encode_json $perl_scalar
1685
1686Converts the given Perl data structure to a UTF-8 encoded, binary string.
1687
1688This function call is functionally identical to:
1689
1690    $json_text = JSON::PP->new->utf8->encode($perl_scalar)
1691
1692=head2 decode_json
1693
1694    $perl_scalar = decode_json $json_text
1695
1696The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
1697to parse that as an UTF-8 encoded JSON text, returning the resulting
1698reference.
1699
1700This function call is functionally identical to:
1701
1702    $perl_scalar = JSON::PP->new->utf8->decode($json_text)
1703
1704=head2 JSON::PP::is_bool
1705
1706    $is_boolean = JSON::PP::is_bool($scalar)
1707
1708Returns true if the passed scalar represents either JSON::PP::true or
1709JSON::PP::false, two constants that act like C<1> and C<0> respectively
1710and are also used to represent JSON C<true> and C<false> in Perl strings.
1711
1712=head2 JSON::PP::true
1713
1714Returns JSON true value which is blessed object.
1715It C<isa> JSON::PP::Boolean object.
1716
1717=head2 JSON::PP::false
1718
1719Returns JSON false value which is blessed object.
1720It C<isa> JSON::PP::Boolean object.
1721
1722=head2 JSON::PP::null
1723
1724Returns C<undef>.
1725
1726See L<MAPPING>, below, for more information on how JSON values are mapped to
1727Perl.
1728
1729
1730=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
1731
1732This section supposes that your perl vresion is 5.8 or later.
1733
1734If you know a JSON text from an outer world - a network, a file content, and so on,
1735is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
1736with C<utf8> enable. And the decoded result will contain UNICODE characters.
1737
1738  # from network
1739  my $json        = JSON::PP->new->utf8;
1740  my $json_text   = CGI->new->param( 'json_data' );
1741  my $perl_scalar = $json->decode( $json_text );
1742
1743  # from file content
1744  local $/;
1745  open( my $fh, '<', 'json.data' );
1746  $json_text   = <$fh>;
1747  $perl_scalar = decode_json( $json_text );
1748
1749If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
1750
1751  use Encode;
1752  local $/;
1753  open( my $fh, '<', 'json.data' );
1754  my $encoding = 'cp932';
1755  my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
1756
1757  # or you can write the below code.
1758  #
1759  # open( my $fh, "<:encoding($encoding)", 'json.data' );
1760  # $unicode_json_text = <$fh>;
1761
1762In this case, C<$unicode_json_text> is of course UNICODE string.
1763So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
1764Instead of them, you use C<JSON> module object with C<utf8> disable.
1765
1766  $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
1767
1768Or C<encode 'utf8'> and C<decode_json>:
1769
1770  $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
1771  # this way is not efficient.
1772
1773And now, you want to convert your C<$perl_scalar> into JSON data and
1774send it to an outer world - a network or a file content, and so on.
1775
1776Your data usually contains UNICODE strings and you want the converted data to be encoded
1777in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
1778
1779  print encode_json( $perl_scalar ); # to a network? file? or display?
1780  # or
1781  print $json->utf8->encode( $perl_scalar );
1782
1783If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
1784for some reason, then its characters are regarded as B<latin1> for perl
1785(because it does not concern with your $encoding).
1786You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
1787Instead of them, you use C<JSON> module object with C<utf8> disable.
1788Note that the resulted text is a UNICODE string but no problem to print it.
1789
1790  # $perl_scalar contains $encoding encoded string values
1791  $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
1792  # $unicode_json_text consists of characters less than 0x100
1793  print $unicode_json_text;
1794
1795Or C<decode $encoding> all string values and C<encode_json>:
1796
1797  $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
1798  # ... do it to each string values, then encode_json
1799  $json_text = encode_json( $perl_scalar );
1800
1801This method is a proper way but probably not efficient.
1802
1803See to L<Encode>, L<perluniintro>.
1804
1805
1806=head1 METHODS
1807
1808Basically, check to L<JSON> or L<JSON::XS>.
1809
1810=head2 new
1811
1812    $json = JSON::PP->new
1813
1814Rturns a new JSON::PP object that can be used to de/encode JSON
1815strings.
1816
1817All boolean flags described below are by default I<disabled>.
1818
1819The mutators for flags all return the JSON object again and thus calls can
1820be chained:
1821
1822   my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
1823   => {"a": [1, 2]}
1824
1825=head2 ascii
1826
1827    $json = $json->ascii([$enable])
1828
1829    $enabled = $json->get_ascii
1830
1831If $enable is true (or missing), then the encode method will not generate characters outside
1832the code range 0..127. Any Unicode characters outside that range will be escaped using either
1833a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
1834(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
1835
1836In Perl 5.005, there is no character having high value (more than 255).
1837See to L<UNICODE HANDLING ON PERLS>.
1838
1839If $enable is false, then the encode method will not escape Unicode characters unless
1840required by the JSON syntax or other flags. This results in a faster and more compact format.
1841
1842  JSON::PP->new->ascii(1)->encode([chr 0x10401])
1843  => ["\ud801\udc01"]
1844
1845=head2 latin1
1846
1847    $json = $json->latin1([$enable])
1848
1849    $enabled = $json->get_latin1
1850
1851If $enable is true (or missing), then the encode method will encode the resulting JSON
1852text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
1853
1854If $enable is false, then the encode method will not escape Unicode characters
1855unless required by the JSON syntax or other flags.
1856
1857  JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
1858  => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
1859
1860See to L<UNICODE HANDLING ON PERLS>.
1861
1862=head2 utf8
1863
1864    $json = $json->utf8([$enable])
1865
1866    $enabled = $json->get_utf8
1867
1868If $enable is true (or missing), then the encode method will encode the JSON result
1869into UTF-8, as required by many protocols, while the decode method expects to be handled
1870an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
1871characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
1872
1873(In Perl 5.005, any character outside the range 0..255 does not exist.
1874See to L<UNICODE HANDLING ON PERLS>.)
1875
1876In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
1877encoding families, as described in RFC4627.
1878
1879If $enable is false, then the encode method will return the JSON string as a (non-encoded)
1880Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
1881(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
1882
1883Example, output UTF-16BE-encoded JSON:
1884
1885  use Encode;
1886  $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
1887
1888Example, decode UTF-32LE-encoded JSON:
1889
1890  use Encode;
1891  $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
1892
1893
1894=head2 pretty
1895
1896    $json = $json->pretty([$enable])
1897
1898This enables (or disables) all of the C<indent>, C<space_before> and
1899C<space_after> flags in one call to generate the most readable
1900(or most compact) form possible.
1901
1902Equivalent to:
1903
1904   $json->indent->space_before->space_after
1905
1906=head2 indent
1907
1908    $json = $json->indent([$enable])
1909
1910    $enabled = $json->get_indent
1911
1912The default indent space length is three.
1913You can use C<indent_length> to change the length.
1914
1915=head2 space_before
1916
1917    $json = $json->space_before([$enable])
1918
1919    $enabled = $json->get_space_before
1920
1921If C<$enable> is true (or missing), then the C<encode> method will add an extra
1922optional space before the C<:> separating keys from values in JSON objects.
1923
1924If C<$enable> is false, then the C<encode> method will not add any extra
1925space at those places.
1926
1927This setting has no effect when decoding JSON texts.
1928
1929Example, space_before enabled, space_after and indent disabled:
1930
1931   {"key" :"value"}
1932
1933=head2 space_after
1934
1935    $json = $json->space_after([$enable])
1936
1937    $enabled = $json->get_space_after
1938
1939If C<$enable> is true (or missing), then the C<encode> method will add an extra
1940optional space after the C<:> separating keys from values in JSON objects
1941and extra whitespace after the C<,> separating key-value pairs and array
1942members.
1943
1944If C<$enable> is false, then the C<encode> method will not add any extra
1945space at those places.
1946
1947This setting has no effect when decoding JSON texts.
1948
1949Example, space_before and indent disabled, space_after enabled:
1950
1951   {"key": "value"}
1952
1953=head2 relaxed
1954
1955    $json = $json->relaxed([$enable])
1956
1957    $enabled = $json->get_relaxed
1958
1959If C<$enable> is true (or missing), then C<decode> will accept some
1960extensions to normal JSON syntax (see below). C<encode> will not be
1961affected in anyway. I<Be aware that this option makes you accept invalid
1962JSON texts as if they were valid!>. I suggest only to use this option to
1963parse application-specific files written by humans (configuration files,
1964resource files etc.)
1965
1966If C<$enable> is false (the default), then C<decode> will only accept
1967valid JSON texts.
1968
1969Currently accepted extensions are:
1970
1971=over 4
1972
1973=item * list items can have an end-comma
1974
1975JSON I<separates> array elements and key-value pairs with commas. This
1976can be annoying if you write JSON texts manually and want to be able to
1977quickly append elements, so this extension accepts comma at the end of
1978such items not just between them:
1979
1980   [
1981      1,
1982      2, <- this comma not normally allowed
1983   ]
1984   {
1985      "k1": "v1",
1986      "k2": "v2", <- this comma not normally allowed
1987   }
1988
1989=item * shell-style '#'-comments
1990
1991Whenever JSON allows whitespace, shell-style comments are additionally
1992allowed. They are terminated by the first carriage-return or line-feed
1993character, after which more white-space and comments are allowed.
1994
1995  [
1996     1, # this comment not allowed in JSON
1997        # neither this one...
1998  ]
1999
2000=back
2001
2002=head2 canonical
2003
2004    $json = $json->canonical([$enable])
2005
2006    $enabled = $json->get_canonical
2007
2008If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
2009by sorting their keys. This is adding a comparatively high overhead.
2010
2011If C<$enable> is false, then the C<encode> method will output key-value
2012pairs in the order Perl stores them (which will likely change between runs
2013of the same script).
2014
2015This option is useful if you want the same data structure to be encoded as
2016the same JSON text (given the same overall settings). If it is disabled,
2017the same hash might be encoded differently even if contains the same data,
2018as key-value pairs have no inherent ordering in Perl.
2019
2020This setting has no effect when decoding JSON texts.
2021
2022If you want your own sorting routine, you can give a code referece
2023or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
2024
2025=head2 allow_nonref
2026
2027    $json = $json->allow_nonref([$enable])
2028
2029    $enabled = $json->get_allow_nonref
2030
2031If C<$enable> is true (or missing), then the C<encode> method can convert a
2032non-reference into its corresponding string, number or null JSON value,
2033which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
2034values instead of croaking.
2035
2036If C<$enable> is false, then the C<encode> method will croak if it isn't
2037passed an arrayref or hashref, as JSON texts must either be an object
2038or array. Likewise, C<decode> will croak if given something that is not a
2039JSON object or array.
2040
2041   JSON::PP->new->allow_nonref->encode ("Hello, World!")
2042   => "Hello, World!"
2043
2044=head2 allow_unknown
2045
2046    $json = $json->allow_unknown ([$enable])
2047
2048    $enabled = $json->get_allow_unknown
2049
2050If $enable is true (or missing), then "encode" will *not* throw an
2051exception when it encounters values it cannot represent in JSON (for
2052example, filehandles) but instead will encode a JSON "null" value.
2053Note that blessed objects are not included here and are handled
2054separately by c<allow_nonref>.
2055
2056If $enable is false (the default), then "encode" will throw an
2057exception when it encounters anything it cannot encode as JSON.
2058
2059This option does not affect "decode" in any way, and it is
2060recommended to leave it off unless you know your communications
2061partner.
2062
2063=head2 allow_blessed
2064
2065    $json = $json->allow_blessed([$enable])
2066
2067    $enabled = $json->get_allow_blessed
2068
2069If C<$enable> is true (or missing), then the C<encode> method will not
2070barf when it encounters a blessed reference. Instead, the value of the
2071B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
2072disabled or no C<TO_JSON> method found) or a representation of the
2073object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
2074encoded. Has no effect on C<decode>.
2075
2076If C<$enable> is false (the default), then C<encode> will throw an
2077exception when it encounters a blessed object.
2078
2079=head2 convert_blessed
2080
2081    $json = $json->convert_blessed([$enable])
2082
2083    $enabled = $json->get_convert_blessed
2084
2085If C<$enable> is true (or missing), then C<encode>, upon encountering a
2086blessed object, will check for the availability of the C<TO_JSON> method
2087on the object's class. If found, it will be called in scalar context
2088and the resulting scalar will be encoded instead of the object. If no
2089C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
2090to do.
2091
2092The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
2093returns other blessed objects, those will be handled in the same
2094way. C<TO_JSON> must take care of not causing an endless recursion cycle
2095(== crash) in this case. The name of C<TO_JSON> was chosen because other
2096methods called by the Perl core (== not by the user of the object) are
2097usually in upper case letters and to avoid collisions with the C<to_json>
2098function or method.
2099
2100This setting does not yet influence C<decode> in any way.
2101
2102If C<$enable> is false, then the C<allow_blessed> setting will decide what
2103to do when a blessed object is found.
2104
2105=head2 filter_json_object
2106
2107    $json = $json->filter_json_object([$coderef])
2108
2109When C<$coderef> is specified, it will be called from C<decode> each
2110time it decodes a JSON object. The only argument passed to the coderef
2111is a reference to the newly-created hash. If the code references returns
2112a single scalar (which need not be a reference), this value
2113(i.e. a copy of that scalar to avoid aliasing) is inserted into the
2114deserialised data structure. If it returns an empty list
2115(NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
2116hash will be inserted. This setting can slow down decoding considerably.
2117
2118When C<$coderef> is omitted or undefined, any existing callback will
2119be removed and C<decode> will not change the deserialised hash in any
2120way.
2121
2122Example, convert all JSON objects into the integer 5:
2123
2124   my $js = JSON::PP->new->filter_json_object (sub { 5 });
2125   # returns [5]
2126   $js->decode ('[{}]'); # the given subroutine takes a hash reference.
2127   # throw an exception because allow_nonref is not enabled
2128   # so a lone 5 is not allowed.
2129   $js->decode ('{"a":1, "b":2}');
2130
2131=head2 filter_json_single_key_object
2132
2133    $json = $json->filter_json_single_key_object($key [=> $coderef])
2134
2135Works remotely similar to C<filter_json_object>, but is only called for
2136JSON objects having a single key named C<$key>.
2137
2138This C<$coderef> is called before the one specified via
2139C<filter_json_object>, if any. It gets passed the single value in the JSON
2140object. If it returns a single value, it will be inserted into the data
2141structure. If it returns nothing (not even C<undef> but the empty list),
2142the callback from C<filter_json_object> will be called next, as if no
2143single-key callback were specified.
2144
2145If C<$coderef> is omitted or undefined, the corresponding callback will be
2146disabled. There can only ever be one callback for a given key.
2147
2148As this callback gets called less often then the C<filter_json_object>
2149one, decoding speed will not usually suffer as much. Therefore, single-key
2150objects make excellent targets to serialise Perl objects into, especially
2151as single-key JSON objects are as close to the type-tagged value concept
2152as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
2153support this in any way, so you need to make sure your data never looks
2154like a serialised Perl hash.
2155
2156Typical names for the single object key are C<__class_whatever__>, or
2157C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
2158things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
2159with real hashes.
2160
2161Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
2162into the corresponding C<< $WIDGET{<id>} >> object:
2163
2164   # return whatever is in $WIDGET{5}:
2165   JSON::PP
2166      ->new
2167      ->filter_json_single_key_object (__widget__ => sub {
2168            $WIDGET{ $_[0] }
2169         })
2170      ->decode ('{"__widget__": 5')
2171
2172   # this can be used with a TO_JSON method in some "widget" class
2173   # for serialisation to json:
2174   sub WidgetBase::TO_JSON {
2175      my ($self) = @_;
2176
2177      unless ($self->{id}) {
2178         $self->{id} = ..get..some..id..;
2179         $WIDGET{$self->{id}} = $self;
2180      }
2181
2182      { __widget__ => $self->{id} }
2183   }
2184
2185=head2 shrink
2186
2187    $json = $json->shrink([$enable])
2188
2189    $enabled = $json->get_shrink
2190
2191In JSON::XS, this flag resizes strings generated by either
2192C<encode> or C<decode> to their minimum size possible.
2193It will also try to downgrade any strings to octet-form if possible.
2194
2195In JSON::PP, it is noop about resizing strings but tries
2196C<utf8::downgrade> to the returned string by C<encode>.
2197See to L<utf8>.
2198
2199See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
2200
2201=head2 max_depth
2202
2203    $json = $json->max_depth([$maximum_nesting_depth])
2204
2205    $max_depth = $json->get_max_depth
2206
2207Sets the maximum nesting level (default C<512>) accepted while encoding
2208or decoding. If a higher nesting level is detected in JSON text or a Perl
2209data structure, then the encoder and decoder will stop and croak at that
2210point.
2211
2212Nesting level is defined by number of hash- or arrayrefs that the encoder
2213needs to traverse to reach a given point or the number of C<{> or C<[>
2214characters without their matching closing parenthesis crossed to reach a
2215given character in a string.
2216
2217If no argument is given, the highest possible setting will be used, which
2218is rarely useful.
2219
2220See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
2221
2222When a large value (100 or more) was set and it de/encodes a deep nested object/text,
2223it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
2224
2225=head2 max_size
2226
2227    $json = $json->max_size([$maximum_string_size])
2228
2229    $max_size = $json->get_max_size
2230
2231Set the maximum length a JSON text may have (in bytes) where decoding is
2232being attempted. The default is C<0>, meaning no limit. When C<decode>
2233is called on a string that is longer then this many bytes, it will not
2234attempt to decode the string but throw an exception. This setting has no
2235effect on C<encode> (yet).
2236
2237If no argument is given, the limit check will be deactivated (same as when
2238C<0> is specified).
2239
2240See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
2241
2242=head2 encode
2243
2244    $json_text = $json->encode($perl_scalar)
2245
2246Converts the given Perl data structure (a simple scalar or a reference
2247to a hash or array) to its JSON representation. Simple scalars will be
2248converted into JSON string or number sequences, while references to arrays
2249become JSON arrays and references to hashes become JSON objects. Undefined
2250Perl values (e.g. C<undef>) become JSON C<null> values.
2251References to the integers C<0> and C<1> are converted into C<true> and C<false>.
2252
2253=head2 decode
2254
2255    $perl_scalar = $json->decode($json_text)
2256
2257The opposite of C<encode>: expects a JSON text and tries to parse it,
2258returning the resulting simple scalar or reference. Croaks on error.
2259
2260JSON numbers and strings become simple Perl scalars. JSON arrays become
2261Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
2262C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
2263C<null> becomes C<undef>.
2264
2265=head2 decode_prefix
2266
2267    ($perl_scalar, $characters) = $json->decode_prefix($json_text)
2268
2269This works like the C<decode> method, but instead of raising an exception
2270when there is trailing garbage after the first JSON object, it will
2271silently stop parsing there and return the number of characters consumed
2272so far.
2273
2274   JSON->new->decode_prefix ("[1] the tail")
2275   => ([], 3)
2276
2277=head1 INCREMENTAL PARSING
2278
2279Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
2280
2281In some cases, there is the need for incremental parsing of JSON texts.
2282This module does allow you to parse a JSON stream incrementally.
2283It does so by accumulating text until it has a full JSON object, which
2284it then can decode. This process is similar to using C<decode_prefix>
2285to see if a full JSON object is available, but is much more efficient
2286(and can be implemented with a minimum of method calls).
2287
2288This module will only attempt to parse the JSON text once it is sure it
2289has enough text to get a decisive result, using a very simple but
2290truly incremental parser. This means that it sometimes won't stop as
2291early as the full parser, for example, it doesn't detect parenthese
2292mismatches. The only thing it guarantees is that it starts decoding as
2293soon as a syntactically valid JSON text has been seen. This means you need
2294to set resource limits (e.g. C<max_size>) to ensure the parser will stop
2295parsing in the presence if syntax errors.
2296
2297The following methods implement this incremental parser.
2298
2299=head2 incr_parse
2300
2301    $json->incr_parse( [$string] ) # void context
2302
2303    $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
2304
2305    @obj_or_empty = $json->incr_parse( [$string] ) # list context
2306
2307This is the central parsing function. It can both append new text and
2308extract objects from the stream accumulated so far (both of these
2309functions are optional).
2310
2311If C<$string> is given, then this string is appended to the already
2312existing JSON fragment stored in the C<$json> object.
2313
2314After that, if the function is called in void context, it will simply
2315return without doing anything further. This can be used to add more text
2316in as many chunks as you want.
2317
2318If the method is called in scalar context, then it will try to extract
2319exactly I<one> JSON object. If that is successful, it will return this
2320object, otherwise it will return C<undef>. If there is a parse error,
2321this method will croak just as C<decode> would do (one can then use
2322C<incr_skip> to skip the errornous part). This is the most common way of
2323using the method.
2324
2325And finally, in list context, it will try to extract as many objects
2326from the stream as it can find and return them, or the empty list
2327otherwise. For this to work, there must be no separators between the JSON
2328objects or arrays, instead they must be concatenated back-to-back. If
2329an error occurs, an exception will be raised as in the scalar context
2330case. Note that in this case, any previously-parsed JSON texts will be
2331lost.
2332
2333Example: Parse some JSON arrays/objects in a given string and return them.
2334
2335    my @objs = JSON->new->incr_parse ("[5][7][1,2]");
2336
2337=head2 incr_text
2338
2339    $lvalue_string = $json->incr_text
2340
2341This method returns the currently stored JSON fragment as an lvalue, that
2342is, you can manipulate it. This I<only> works when a preceding call to
2343C<incr_parse> in I<scalar context> successfully returned an object. Under
2344all other circumstances you must not call this function (I mean it.
2345although in simple tests it might actually work, it I<will> fail under
2346real world conditions). As a special exception, you can also call this
2347method before having parsed anything.
2348
2349This function is useful in two cases: a) finding the trailing text after a
2350JSON object or b) parsing multiple JSON objects separated by non-JSON text
2351(such as commas).
2352
2353    $json->incr_text =~ s/\s*,\s*//;
2354
2355In Perl 5.005, C<lvalue> attribute is not available.
2356You must write codes like the below:
2357
2358    $string = $json->incr_text;
2359    $string =~ s/\s*,\s*//;
2360    $json->incr_text( $string );
2361
2362=head2 incr_skip
2363
2364    $json->incr_skip
2365
2366This will reset the state of the incremental parser and will remove the
2367parsed text from the input buffer. This is useful after C<incr_parse>
2368died, in which case the input buffer and incremental parser state is left
2369unchanged, to skip the text parsed so far and to reset the parse state.
2370
2371=head2 incr_reset
2372
2373    $json->incr_reset
2374
2375This completely resets the incremental parser, that is, after this call,
2376it will be as if the parser had never parsed anything.
2377
2378This is useful if you want ot repeatedly parse JSON objects and want to
2379ignore any trailing data, which means you have to reset the parser after
2380each successful decode.
2381
2382See to L<JSON::XS/INCREMENTAL PARSING> for examples.
2383
2384
2385=head1 JSON::PP OWN METHODS
2386
2387=head2 allow_singlequote
2388
2389    $json = $json->allow_singlequote([$enable])
2390
2391If C<$enable> is true (or missing), then C<decode> will accept
2392JSON strings quoted by single quotations that are invalid JSON
2393format.
2394
2395    $json->allow_singlequote->decode({"foo":'bar'});
2396    $json->allow_singlequote->decode({'foo':"bar"});
2397    $json->allow_singlequote->decode({'foo':'bar'});
2398
2399As same as the C<relaxed> option, this option may be used to parse
2400application-specific files written by humans.
2401
2402
2403=head2 allow_barekey
2404
2405    $json = $json->allow_barekey([$enable])
2406
2407If C<$enable> is true (or missing), then C<decode> will accept
2408bare keys of JSON object that are invalid JSON format.
2409
2410As same as the C<relaxed> option, this option may be used to parse
2411application-specific files written by humans.
2412
2413    $json->allow_barekey->decode('{foo:"bar"}');
2414
2415=head2 allow_bignum
2416
2417    $json = $json->allow_bignum([$enable])
2418
2419If C<$enable> is true (or missing), then C<decode> will convert
2420the big integer Perl cannot handle as integer into a L<Math::BigInt>
2421object and convert a floating number (any) into a L<Math::BigFloat>.
2422
2423On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
2424objects into JSON numbers with C<allow_blessed> enable.
2425
2426   $json->allow_nonref->allow_blessed->allow_bignum;
2427   $bigfloat = $json->decode('2.000000000000000000000000001');
2428   print $json->encode($bigfloat);
2429   # => 2.000000000000000000000000001
2430
2431See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
2432
2433=head2 loose
2434
2435    $json = $json->loose([$enable])
2436
2437The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
2438and the module doesn't allow to C<decode> to these (except for \x2f).
2439If C<$enable> is true (or missing), then C<decode>  will accept these
2440unescaped strings.
2441
2442    $json->loose->decode(qq|["abc
2443                                   def"]|);
2444
2445See L<JSON::XS/SSECURITY CONSIDERATIONS>.
2446
2447=head2 escape_slash
2448
2449    $json = $json->escape_slash([$enable])
2450
2451According to JSON Grammar, I<slash> (U+002F) is escaped. But default
2452JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
2453
2454If C<$enable> is true (or missing), then C<encode> will escape slashes.
2455
2456=head2 indent_length
2457
2458    $json = $json->indent_length($length)
2459
2460JSON::XS indent space length is 3 and cannot be changed.
2461JSON::PP set the indent space length with the given $length.
2462The default is 3. The acceptable range is 0 to 15.
2463
2464=head2 sort_by
2465
2466    $json = $json->sort_by($function_name)
2467    $json = $json->sort_by($subroutine_ref)
2468
2469If $function_name or $subroutine_ref are set, its sort routine are used
2470in encoding JSON objects.
2471
2472   $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
2473   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2474
2475   $js = $pc->sort_by('own_sort')->encode($obj);
2476   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2477
2478   sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
2479
2480As the sorting routine runs in the JSON::PP scope, the given
2481subroutine name and the special variables C<$a>, C<$b> will begin
2482'JSON::PP::'.
2483
2484If $integer is set, then the effect is same as C<canonical> on.
2485
2486=head1 INTERNAL
2487
2488For developers.
2489
2490=over
2491
2492=item PP_encode_box
2493
2494Returns
2495
2496        {
2497            depth        => $depth,
2498            indent_count => $indent_count,
2499        }
2500
2501
2502=item PP_decode_box
2503
2504Returns
2505
2506        {
2507            text    => $text,
2508            at      => $at,
2509            ch      => $ch,
2510            len     => $len,
2511            depth   => $depth,
2512            encoding      => $encoding,
2513            is_valid_utf8 => $is_valid_utf8,
2514        };
2515
2516=back
2517
2518=head1 MAPPING
2519
2520This section is copied from JSON::XS and modified to C<JSON::PP>.
2521JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
2522
2523See to L<JSON::XS/MAPPING>.
2524
2525=head2 JSON -> PERL
2526
2527=over 4
2528
2529=item object
2530
2531A JSON object becomes a reference to a hash in Perl. No ordering of object
2532keys is preserved (JSON does not preserver object key ordering itself).
2533
2534=item array
2535
2536A JSON array becomes a reference to an array in Perl.
2537
2538=item string
2539
2540A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
2541are represented by the same codepoints in the Perl string, so no manual
2542decoding is necessary.
2543
2544=item number
2545
2546A JSON number becomes either an integer, numeric (floating point) or
2547string scalar in perl, depending on its range and any fractional parts. On
2548the Perl level, there is no difference between those as Perl handles all
2549the conversion details, but an integer may take slightly less memory and
2550might represent more values exactly than floating point numbers.
2551
2552If the number consists of digits only, C<JSON> will try to represent
2553it as an integer value. If that fails, it will try to represent it as
2554a numeric (floating point) value if that is possible without loss of
2555precision. Otherwise it will preserve the number as a string value (in
2556which case you lose roundtripping ability, as the JSON number will be
2557re-encoded toa JSON string).
2558
2559Numbers containing a fractional or exponential part will always be
2560represented as numeric (floating point) values, possibly at a loss of
2561precision (in which case you might lose perfect roundtripping ability, but
2562the JSON number will still be re-encoded as a JSON number).
2563
2564Note that precision is not accuracy - binary floating point values cannot
2565represent most decimal fractions exactly, and when converting from and to
2566floating point, C<JSON> only guarantees precision up to but not including
2567the leats significant bit.
2568
2569When C<allow_bignum> is enable, the big integers
2570and the numeric can be optionally converted into L<Math::BigInt> and
2571L<Math::BigFloat> objects.
2572
2573=item true, false
2574
2575These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
2576respectively. They are overloaded to act almost exactly like the numbers
2577C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
2578the C<JSON::is_bool> function.
2579
2580   print JSON::PP::true . "\n";
2581    => true
2582   print JSON::PP::true + 1;
2583    => 1
2584
2585   ok(JSON::true eq  '1');
2586   ok(JSON::true == 1);
2587
2588C<JSON> will install these missing overloading features to the backend modules.
2589
2590
2591=item null
2592
2593A JSON null atom becomes C<undef> in Perl.
2594
2595C<JSON::PP::null> returns C<unddef>.
2596
2597=back
2598
2599
2600=head2 PERL -> JSON
2601
2602The mapping from Perl to JSON is slightly more difficult, as Perl is a
2603truly typeless language, so we can only guess which JSON type is meant by
2604a Perl value.
2605
2606=over 4
2607
2608=item hash references
2609
2610Perl hash references become JSON objects. As there is no inherent ordering
2611in hash keys (or JSON objects), they will usually be encoded in a
2612pseudo-random order that can change between runs of the same program but
2613stays generally the same within a single run of a program. C<JSON>
2614optionally sort the hash keys (determined by the I<canonical> flag), so
2615the same datastructure will serialise to the same JSON text (given same
2616settings and version of JSON::XS), but this incurs a runtime overhead
2617and is only rarely useful, e.g. when you want to compare some JSON text
2618against another for equality.
2619
2620
2621=item array references
2622
2623Perl array references become JSON arrays.
2624
2625=item other references
2626
2627Other unblessed references are generally not allowed and will cause an
2628exception to be thrown, except for references to the integers C<0> and
2629C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
2630also use C<JSON::false> and C<JSON::true> to improve readability.
2631
2632   to_json [\0,JSON::PP::true]      # yields [false,true]
2633
2634=item JSON::PP::true, JSON::PP::false, JSON::PP::null
2635
2636These special values become JSON true and JSON false values,
2637respectively. You can also use C<\1> and C<\0> directly if you want.
2638
2639JSON::PP::null returns C<undef>.
2640
2641=item blessed objects
2642
2643Blessed objects are not directly representable in JSON. See the
2644C<allow_blessed> and C<convert_blessed> methods on various options on
2645how to deal with this: basically, you can choose between throwing an
2646exception, encoding the reference as if it weren't blessed, or provide
2647your own serialiser method.
2648
2649See to L<convert_blessed>.
2650
2651=item simple scalars
2652
2653Simple Perl scalars (any scalar that is not a reference) are the most
2654difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
2655JSON C<null> values, scalars that have last been used in a string context
2656before encoding as JSON strings, and anything else as number value:
2657
2658   # dump as number
2659   encode_json [2]                      # yields [2]
2660   encode_json [-3.0e17]                # yields [-3e+17]
2661   my $value = 5; encode_json [$value]  # yields [5]
2662
2663   # used as string, so dump as string
2664   print $value;
2665   encode_json [$value]                 # yields ["5"]
2666
2667   # undef becomes null
2668   encode_json [undef]                  # yields [null]
2669
2670You can force the type to be a string by stringifying it:
2671
2672   my $x = 3.1; # some variable containing a number
2673   "$x";        # stringified
2674   $x .= "";    # another, more awkward way to stringify
2675   print $x;    # perl does it for you, too, quite often
2676
2677You can force the type to be a number by numifying it:
2678
2679   my $x = "3"; # some variable containing a string
2680   $x += 0;     # numify it, ensuring it will be dumped as a number
2681   $x *= 1;     # same thing, the choise is yours.
2682
2683You can not currently force the type in other, less obscure, ways.
2684
2685Note that numerical precision has the same meaning as under Perl (so
2686binary to decimal conversion follows the same rules as in Perl, which
2687can differ to other languages). Also, your perl interpreter might expose
2688extensions to the floating point numbers of your platform, such as
2689infinities or NaN's - these cannot be represented in JSON, and it is an
2690error to pass those in.
2691
2692=item Big Number
2693
2694When C<allow_bignum> is enable,
2695C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
2696objects into JSON numbers.
2697
2698
2699=back
2700
2701=head1 UNICODE HANDLING ON PERLS
2702
2703If you do not know about Unicode on Perl well,
2704please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
2705
2706=head2 Perl 5.8 and later
2707
2708Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
2709
2710    $json->allow_nonref->encode(chr hex 3042);
2711    $json->allow_nonref->encode(chr hex 12345);
2712
2713Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
2714
2715    $json->allow_nonref->decode('"\u3042"');
2716    $json->allow_nonref->decode('"\ud808\udf45"');
2717
2718Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
2719
2720Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
2721so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
2722
2723
2724=head2 Perl 5.6
2725
2726Perl can handle Unicode and the JSON::PP de/encode methods also work.
2727
2728=head2 Perl 5.005
2729
2730Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
2731That means the unicode handling is not available.
2732
2733In encoding,
2734
2735    $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
2736    $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
2737
2738Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
2739as C<$value % 256>, so the above codes are equivalent to :
2740
2741    $json->allow_nonref->encode(chr 66);
2742    $json->allow_nonref->encode(chr 69);
2743
2744In decoding,
2745
2746    $json->decode('"\u00e3\u0081\u0082"');
2747
2748The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
2749japanese character (C<HIRAGANA LETTER A>).
2750And if it is represented in Unicode code point, C<U+3042>.
2751
2752Next,
2753
2754    $json->decode('"\u3042"');
2755
2756We ordinary expect the returned value is a Unicode character C<U+3042>.
2757But here is 5.005 world. This is C<0xE3 0x81 0x82>.
2758
2759    $json->decode('"\ud808\udf45"');
2760
2761This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
2762
2763
2764=head1 TODO
2765
2766=over
2767
2768=item speed
2769
2770=item memory saving
2771
2772=back
2773
2774
2775=head1 SEE ALSO
2776
2777Most of the document are copied and modified from JSON::XS doc.
2778
2779L<JSON::XS>
2780
2781RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
2782
2783=head1 AUTHOR
2784
2785Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
2786
2787
2788=head1 COPYRIGHT AND LICENSE
2789
2790Copyright 2007-2014 by Makamaka Hannyaharamitu
2791
2792This library is free software; you can redistribute it and/or modify
2793it under the same terms as Perl itself.
2794
2795=cut
2796