1package JSON::PP;
2
3# JSON-2.0
4
5use 5.008;
6use strict;
7
8use Exporter ();
9BEGIN { our @ISA = ('Exporter') }
10
11use overload ();
12use JSON::PP::Boolean;
13
14use Carp ();
15use Scalar::Util qw(blessed reftype refaddr);
16#use Devel::Peek;
17
18our $VERSION = '4.16';
19
20our @EXPORT = qw(encode_json decode_json from_json to_json);
21
22# instead of hash-access, i tried index-access for speed.
23# but this method is not faster than what i expected. so it will be changed.
24
25use constant P_ASCII                => 0;
26use constant P_LATIN1               => 1;
27use constant P_UTF8                 => 2;
28use constant P_INDENT               => 3;
29use constant P_CANONICAL            => 4;
30use constant P_SPACE_BEFORE         => 5;
31use constant P_SPACE_AFTER          => 6;
32use constant P_ALLOW_NONREF         => 7;
33use constant P_SHRINK               => 8;
34use constant P_ALLOW_BLESSED        => 9;
35use constant P_CONVERT_BLESSED      => 10;
36use constant P_RELAXED              => 11;
37
38use constant P_LOOSE                => 12;
39use constant P_ALLOW_BIGNUM         => 13;
40use constant P_ALLOW_BAREKEY        => 14;
41use constant P_ALLOW_SINGLEQUOTE    => 15;
42use constant P_ESCAPE_SLASH         => 16;
43use constant P_AS_NONBLESSED        => 17;
44
45use constant P_ALLOW_UNKNOWN        => 18;
46use constant P_ALLOW_TAGS           => 19;
47
48use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0;
49use constant CORE_BOOL => defined &builtin::is_bool;
50
51my $invalid_char_re;
52
53BEGIN {
54    $invalid_char_re = "[";
55    for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok
56        $invalid_char_re .= quotemeta chr utf8::unicode_to_native($i);
57    }
58
59    $invalid_char_re = qr/$invalid_char_re]/;
60}
61
62BEGIN {
63    if (USE_B) {
64        require B;
65    }
66}
67
68BEGIN {
69    my @xs_compati_bit_properties = qw(
70            latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
71            allow_blessed convert_blessed relaxed allow_unknown
72            allow_tags
73    );
74    my @pp_bit_properties = qw(
75            allow_singlequote allow_bignum loose
76            allow_barekey escape_slash as_nonblessed
77    );
78
79    for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
80        my $property_id = 'P_' . uc($name);
81
82        eval qq/
83            sub $name {
84                my \$enable = defined \$_[1] ? \$_[1] : 1;
85
86                if (\$enable) {
87                    \$_[0]->{PROPS}->[$property_id] = 1;
88                }
89                else {
90                    \$_[0]->{PROPS}->[$property_id] = 0;
91                }
92
93                \$_[0];
94            }
95
96            sub get_$name {
97                \$_[0]->{PROPS}->[$property_id] ? 1 : '';
98            }
99        /;
100    }
101
102}
103
104
105
106# Functions
107
108my $JSON; # cache
109
110sub encode_json ($) { # encode
111    ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
112}
113
114
115sub decode_json { # decode
116    ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
117}
118
119# Obsoleted
120
121sub to_json($) {
122   Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
123}
124
125
126sub from_json($) {
127   Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
128}
129
130
131# Methods
132
133sub new {
134    my $class = shift;
135    my $self  = {
136        max_depth   => 512,
137        max_size    => 0,
138        indent_length => 3,
139    };
140
141    $self->{PROPS}[P_ALLOW_NONREF] = 1;
142
143    bless $self, $class;
144}
145
146
147sub encode {
148    return $_[0]->PP_encode_json($_[1]);
149}
150
151
152sub decode {
153    return $_[0]->PP_decode_json($_[1], 0x00000000);
154}
155
156
157sub decode_prefix {
158    return $_[0]->PP_decode_json($_[1], 0x00000001);
159}
160
161
162# accessor
163
164
165# pretty printing
166
167sub pretty {
168    my ($self, $v) = @_;
169    my $enable = defined $v ? $v : 1;
170
171    if ($enable) { # indent_length(3) for JSON::XS compatibility
172        $self->indent(1)->space_before(1)->space_after(1);
173    }
174    else {
175        $self->indent(0)->space_before(0)->space_after(0);
176    }
177
178    $self;
179}
180
181# etc
182
183sub max_depth {
184    my $max  = defined $_[1] ? $_[1] : 0x80000000;
185    $_[0]->{max_depth} = $max;
186    $_[0];
187}
188
189
190sub get_max_depth { $_[0]->{max_depth}; }
191
192
193sub max_size {
194    my $max  = defined $_[1] ? $_[1] : 0;
195    $_[0]->{max_size} = $max;
196    $_[0];
197}
198
199
200sub get_max_size { $_[0]->{max_size}; }
201
202sub boolean_values {
203    my $self = shift;
204    if (@_) {
205        my ($false, $true) = @_;
206        $self->{false} = $false;
207        $self->{true} = $true;
208        if (CORE_BOOL) {
209            BEGIN { CORE_BOOL and warnings->unimport(qw(experimental::builtin)) }
210            if (builtin::is_bool($true) && builtin::is_bool($false) && $true && !$false) {
211                $self->{core_bools} = !!1;
212            }
213            else {
214                delete $self->{core_bools};
215            }
216        }
217    } else {
218        delete $self->{false};
219        delete $self->{true};
220        delete $self->{core_bools};
221    }
222    return $self;
223}
224
225sub core_bools {
226    my $self = shift;
227    my $core_bools = defined $_[0] ? $_[0] : 1;
228    if ($core_bools) {
229        $self->{true} = !!1;
230        $self->{false} = !!0;
231        $self->{core_bools} = !!1;
232    }
233    else {
234        $self->{true} = $JSON::PP::true;
235        $self->{false} = $JSON::PP::false;
236        $self->{core_bools} = !!0;
237    }
238    return $self;
239}
240
241sub get_core_bools {
242    my $self = shift;
243    return !!$self->{core_bools};
244}
245
246sub unblessed_bool {
247    my $self = shift;
248    return $self->core_bools(@_);
249}
250
251sub get_unblessed_bool {
252    my $self = shift;
253    return $self->get_core_bools(@_);
254}
255
256sub get_boolean_values {
257    my $self = shift;
258    if (exists $self->{true} and exists $self->{false}) {
259        return @$self{qw/false true/};
260    }
261    return;
262}
263
264sub filter_json_object {
265    if (defined $_[1] and ref $_[1] eq 'CODE') {
266        $_[0]->{cb_object} = $_[1];
267    } else {
268        delete $_[0]->{cb_object};
269    }
270    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
271    $_[0];
272}
273
274sub filter_json_single_key_object {
275    if (@_ == 1 or @_ > 3) {
276        Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)");
277    }
278    if (defined $_[2] and ref $_[2] eq 'CODE') {
279        $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
280    } else {
281        delete $_[0]->{cb_sk_object}->{$_[1]};
282        delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}};
283    }
284    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
285    $_[0];
286}
287
288sub indent_length {
289    if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
290        Carp::carp "The acceptable range of indent_length() is 0 to 15.";
291    }
292    else {
293        $_[0]->{indent_length} = $_[1];
294    }
295    $_[0];
296}
297
298sub get_indent_length {
299    $_[0]->{indent_length};
300}
301
302sub sort_by {
303    $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
304    $_[0];
305}
306
307sub allow_bigint {
308    Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");
309    $_[0]->allow_bignum;
310}
311
312###############################
313
314###
315### Perl => JSON
316###
317
318
319{ # Convert
320
321    my $max_depth;
322    my $indent;
323    my $ascii;
324    my $latin1;
325    my $utf8;
326    my $space_before;
327    my $space_after;
328    my $canonical;
329    my $allow_blessed;
330    my $convert_blessed;
331
332    my $indent_length;
333    my $escape_slash;
334    my $bignum;
335    my $as_nonblessed;
336    my $allow_tags;
337
338    my $depth;
339    my $indent_count;
340    my $keysort;
341
342
343    sub PP_encode_json {
344        my $self = shift;
345        my $obj  = shift;
346
347        $indent_count = 0;
348        $depth        = 0;
349
350        my $props = $self->{PROPS};
351
352        ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
353            $convert_blessed, $escape_slash, $bignum, $as_nonblessed, $allow_tags)
354         = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
355                    P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED, P_ALLOW_TAGS];
356
357        ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
358
359        $keysort = $canonical ? sub { $a cmp $b } : undef;
360
361        if ($self->{sort_by}) {
362            $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
363                     : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
364                     : sub { $a cmp $b };
365        }
366
367        encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
368             if(!ref $obj and !$props->[ P_ALLOW_NONREF ]);
369
370        my $str  = $self->object_to_json($obj);
371
372        $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
373
374        return $str;
375    }
376
377
378    sub object_to_json {
379        my ($self, $obj) = @_;
380        my $type = ref($obj);
381
382        if($type eq 'HASH'){
383            return $self->hash_to_json($obj);
384        }
385        elsif($type eq 'ARRAY'){
386            return $self->array_to_json($obj);
387        }
388        elsif ($type) { # blessed object?
389            if (blessed($obj)) {
390
391                return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
392
393                if ( $allow_tags and $obj->can('FREEZE') ) {
394                    my $obj_class = ref $obj || $obj;
395                    $obj = bless $obj, $obj_class;
396                    my @results = $obj->FREEZE('JSON');
397                    if ( @results and ref $results[0] ) {
398                        if ( refaddr( $obj ) eq refaddr( $results[0] ) ) {
399                            encode_error( sprintf(
400                                "%s::FREEZE method returned same object as was passed instead of a new one",
401                                ref $obj
402                            ) );
403                        }
404                    }
405                    return '("'.$obj_class.'")['.join(',', @results).']';
406                }
407
408                if ( $convert_blessed and $obj->can('TO_JSON') ) {
409                    my $result = $obj->TO_JSON();
410                    if ( defined $result and ref( $result ) ) {
411                        if ( refaddr( $obj ) eq refaddr( $result ) ) {
412                            encode_error( sprintf(
413                                "%s::TO_JSON method returned same object as was passed instead of a new one",
414                                ref $obj
415                            ) );
416                        }
417                    }
418
419                    return $self->object_to_json( $result );
420                }
421
422                return "$obj" if ( $bignum and _is_bignum($obj) );
423
424                if ($allow_blessed) {
425                    return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed.
426                    return 'null';
427                }
428                encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj)
429                );
430            }
431            else {
432                return $self->value_to_json($obj);
433            }
434        }
435        else{
436            return $self->value_to_json($obj);
437        }
438    }
439
440
441    sub hash_to_json {
442        my ($self, $obj) = @_;
443        my @res;
444
445        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
446                                         if (++$depth > $max_depth);
447
448        my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
449        my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
450
451        for my $k ( _sort( $obj ) ) {
452            push @res, $self->string_to_json( $k )
453                          .  $del
454                          . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) );
455        }
456
457        --$depth;
458        $self->_down_indent() if ($indent);
459
460        return '{}' unless @res;
461        return '{' . $pre . join( ",$pre", @res ) . $post . '}';
462    }
463
464
465    sub array_to_json {
466        my ($self, $obj) = @_;
467        my @res;
468
469        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
470                                         if (++$depth > $max_depth);
471
472        my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
473
474        for my $v (@$obj){
475            push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v);
476        }
477
478        --$depth;
479        $self->_down_indent() if ($indent);
480
481        return '[]' unless @res;
482        return '[' . $pre . join( ",$pre", @res ) . $post . ']';
483    }
484
485    sub _looks_like_number {
486        my $value = shift;
487        if (USE_B) {
488            my $b_obj = B::svref_2object(\$value);
489            my $flags = $b_obj->FLAGS;
490            return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
491            return;
492        } else {
493            no warnings 'numeric';
494            # if the utf8 flag is on, it almost certainly started as a string
495            return if utf8::is_utf8($value);
496            # detect numbers
497            # string & "" -> ""
498            # number & "" -> 0 (with warning)
499            # nan and inf can detect as numbers, so check with * 0
500            return unless length((my $dummy = "") & $value);
501            return unless 0 + $value eq $value;
502            return 1 if $value * 0 == 0;
503            return -1; # inf/nan
504        }
505    }
506
507    sub value_to_json {
508        my ($self, $value) = @_;
509
510        return 'null' if(!defined $value);
511
512        my $type = ref($value);
513
514        if (!$type) {
515            BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
516            if (CORE_BOOL && builtin::is_bool($value)) {
517                return $value ? 'true' : 'false';
518            }
519            elsif (_looks_like_number($value)) {
520                return $value;
521            }
522            return $self->string_to_json($value);
523        }
524        elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
525            return $$value == 1 ? 'true' : 'false';
526        }
527        else {
528            if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
529                return $self->value_to_json("$value");
530            }
531
532            if ($type eq 'SCALAR' and defined $$value) {
533                return   $$value eq '1' ? 'true'
534                       : $$value eq '0' ? 'false'
535                       : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
536                       : encode_error("cannot encode reference to scalar");
537            }
538
539            if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
540                return 'null';
541            }
542            else {
543                if ( $type eq 'SCALAR' or $type eq 'REF' ) {
544                    encode_error("cannot encode reference to scalar");
545                }
546                else {
547                    encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
548                }
549            }
550
551        }
552    }
553
554
555    my %esc = (
556        "\n" => '\n',
557        "\r" => '\r',
558        "\t" => '\t',
559        "\f" => '\f',
560        "\b" => '\b',
561        "\"" => '\"',
562        "\\" => '\\\\',
563        "\'" => '\\\'',
564    );
565
566
567    sub string_to_json {
568        my ($self, $arg) = @_;
569
570        $arg =~ s/(["\\\n\r\t\f\b])/$esc{$1}/g;
571        $arg =~ s/\//\\\//g if ($escape_slash);
572
573        # On ASCII platforms, matches [\x00-\x08\x0b\x0e-\x1f]
574        $arg =~ s/([^\n\t\c?[:^cntrl:][:^ascii:]])/'\\u00' . unpack('H2', $1)/eg;
575
576        if ($ascii) {
577            $arg = _encode_ascii($arg);
578        }
579
580        if ($latin1) {
581            $arg = _encode_latin1($arg);
582        }
583
584        if ($utf8) {
585            utf8::encode($arg);
586        }
587
588        return '"' . $arg . '"';
589    }
590
591
592    sub blessed_to_json {
593        my $reftype = reftype($_[1]) || '';
594        if ($reftype eq 'HASH') {
595            return $_[0]->hash_to_json($_[1]);
596        }
597        elsif ($reftype eq 'ARRAY') {
598            return $_[0]->array_to_json($_[1]);
599        }
600        else {
601            return 'null';
602        }
603    }
604
605
606    sub encode_error {
607        my $error  = shift;
608        Carp::croak "$error";
609    }
610
611
612    sub _sort {
613        defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
614    }
615
616
617    sub _up_indent {
618        my $self  = shift;
619        my $space = ' ' x $indent_length;
620
621        my ($pre,$post) = ('','');
622
623        $post = "\n" . $space x $indent_count;
624
625        $indent_count++;
626
627        $pre = "\n" . $space x $indent_count;
628
629        return ($pre,$post);
630    }
631
632
633    sub _down_indent { $indent_count--; }
634
635
636    sub PP_encode_box {
637        {
638            depth        => $depth,
639            indent_count => $indent_count,
640        };
641    }
642
643} # Convert
644
645
646sub _encode_ascii {
647    join('',
648        map {
649            chr($_) =~ /[[:ascii:]]/ ?
650                chr($_) :
651            $_ <= 65535 ?
652                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
653        } unpack('U*', $_[0])
654    );
655}
656
657
658sub _encode_latin1 {
659    join('',
660        map {
661            $_ <= 255 ?
662                chr($_) :
663            $_ <= 65535 ?
664                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
665        } unpack('U*', $_[0])
666    );
667}
668
669
670sub _encode_surrogates { # from perlunicode
671    my $uni = $_[0] - 0x10000;
672    return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
673}
674
675
676sub _is_bignum {
677    $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
678}
679
680
681
682#
683# JSON => Perl
684#
685
686my $max_intsize;
687
688BEGIN {
689    my $checkint = 1111;
690    for my $d (5..64) {
691        $checkint .= 1;
692        my $int   = eval qq| $checkint |;
693        if ($int =~ /[eE]/) {
694            $max_intsize = $d - 1;
695            last;
696        }
697    }
698}
699
700{ # PARSE
701
702    my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
703        b    => "\b",
704        t    => "\t",
705        n    => "\n",
706        f    => "\f",
707        r    => "\r",
708        '\\' => '\\',
709        '"'  => '"',
710        '/'  => '/',
711    );
712
713    my $text; # json data
714    my $at;   # offset
715    my $ch;   # first character
716    my $len;  # text length (changed according to UTF8 or NON UTF8)
717    # INTERNAL
718    my $depth;          # nest counter
719    my $encoding;       # json text encoding
720    my $is_valid_utf8;  # temp variable
721    my $utf8_len;       # utf8 byte length
722    # FLAGS
723    my $utf8;           # must be utf8
724    my $max_depth;      # max nest number of objects and arrays
725    my $max_size;
726    my $relaxed;
727    my $cb_object;
728    my $cb_sk_object;
729
730    my $F_HOOK;
731
732    my $allow_bignum;   # using Math::BigInt/BigFloat
733    my $singlequote;    # loosely quoting
734    my $loose;          #
735    my $allow_barekey;  # bareKey
736    my $allow_tags;
737
738    my $alt_true;
739    my $alt_false;
740
741    sub _detect_utf_encoding {
742        my $text = shift;
743        my @octets = unpack('C4', $text);
744        return 'unknown' unless defined $octets[3];
745        return ( $octets[0] and  $octets[1]) ? 'UTF-8'
746             : (!$octets[0] and  $octets[1]) ? 'UTF-16BE'
747             : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
748             : ( $octets[2]                ) ? 'UTF-16LE'
749             : (!$octets[2]                ) ? 'UTF-32LE'
750             : 'unknown';
751    }
752
753    sub PP_decode_json {
754        my ($self, $want_offset);
755
756        ($self, $text, $want_offset) = @_;
757
758        ($at, $ch, $depth) = (0, '', 0);
759
760        if ( !defined $text or ref $text ) {
761            decode_error("malformed JSON string, neither array, object, number, string or atom");
762        }
763
764        my $props = $self->{PROPS};
765
766        ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote, $allow_tags)
767            = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE, P_ALLOW_TAGS];
768
769        ($alt_true, $alt_false) = @$self{qw/true false/};
770
771        if ( $utf8 ) {
772            $encoding = _detect_utf_encoding($text);
773            if ($encoding ne 'UTF-8' and $encoding ne 'unknown') {
774                require Encode;
775                Encode::from_to($text, $encoding, 'utf-8');
776            } else {
777                utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
778            }
779        }
780        else {
781            utf8::encode( $text );
782        }
783
784        $len = length $text;
785
786        ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
787             = @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};
788
789        if ($max_size > 1) {
790            use bytes;
791            my $bytes = length $text;
792            decode_error(
793                sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
794                    , $bytes, $max_size), 1
795            ) if ($bytes > $max_size);
796        }
797
798        white(); # remove head white space
799
800        decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure?
801
802        my $result = value();
803
804        if ( !$props->[ P_ALLOW_NONREF ] and !ref $result ) {
805                decode_error(
806                'JSON text must be an object or array (but found number, string, true, false or null,'
807                       . ' use allow_nonref to allow this)', 1);
808        }
809
810        Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
811
812        my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
813
814        white(); # remove tail white space
815
816        return ( $result, $consumed ) if $want_offset; # all right if decode_prefix
817
818        decode_error("garbage after JSON object") if defined $ch;
819
820        $result;
821    }
822
823
824    sub next_chr {
825        return $ch = undef if($at >= $len);
826        $ch = substr($text, $at++, 1);
827    }
828
829
830    sub value {
831        white();
832        return          if(!defined $ch);
833        return object() if($ch eq '{');
834        return array()  if($ch eq '[');
835        return tag()    if($ch eq '(');
836        return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
837        return number() if($ch =~ /[0-9]/ or $ch eq '-');
838        return word();
839    }
840
841    sub string {
842        my $utf16;
843        my $is_utf8;
844
845        ($is_valid_utf8, $utf8_len) = ('', 0);
846
847        my $s = ''; # basically UTF8 flag on
848
849        if($ch eq '"' or ($singlequote and $ch eq "'")){
850            my $boundChar = $ch;
851
852            OUTER: while( defined(next_chr()) ){
853
854                if($ch eq $boundChar){
855                    next_chr();
856
857                    if ($utf16) {
858                        decode_error("missing low surrogate character in surrogate pair");
859                    }
860
861                    utf8::decode($s) if($is_utf8);
862
863                    return $s;
864                }
865                elsif($ch eq '\\'){
866                    next_chr();
867                    if(exists $escapes{$ch}){
868                        $s .= $escapes{$ch};
869                    }
870                    elsif($ch eq 'u'){ # UNICODE handling
871                        my $u = '';
872
873                        for(1..4){
874                            $ch = next_chr();
875                            last OUTER if($ch !~ /[0-9a-fA-F]/);
876                            $u .= $ch;
877                        }
878
879                        # U+D800 - U+DBFF
880                        if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
881                            $utf16 = $u;
882                        }
883                        # U+DC00 - U+DFFF
884                        elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
885                            unless (defined $utf16) {
886                                decode_error("missing high surrogate character in surrogate pair");
887                            }
888                            $is_utf8 = 1;
889                            $s .= _decode_surrogates($utf16, $u) || next;
890                            $utf16 = undef;
891                        }
892                        else {
893                            if (defined $utf16) {
894                                decode_error("surrogate pair expected");
895                            }
896
897                            my $hex = hex( $u );
898                            if ( chr $u =~ /[[:^ascii:]]/ ) {
899                                $is_utf8 = 1;
900                                $s .= _decode_unicode($u) || next;
901                            }
902                            else {
903                                $s .= chr $hex;
904                            }
905                        }
906
907                    }
908                    else{
909                        unless ($loose) {
910                            $at -= 2;
911                            decode_error('illegal backslash escape sequence in string');
912                        }
913                        $s .= $ch;
914                    }
915                }
916                else{
917
918                    if ( $ch =~ /[[:^ascii:]]/ ) {
919                        unless( $ch = is_valid_utf8($ch) ) {
920                            $at -= 1;
921                            decode_error("malformed UTF-8 character in JSON string");
922                        }
923                        else {
924                            $at += $utf8_len - 1;
925                        }
926
927                        $is_utf8 = 1;
928                    }
929
930                    if (!$loose) {
931                        if ($ch =~ $invalid_char_re)  { # '/' ok
932                            if (!$relaxed or $ch ne "\t") {
933                                $at--;
934                                decode_error(sprintf "invalid character 0x%X"
935                                   . " encountered while parsing JSON string",
936                                   ord $ch);
937                            }
938                        }
939                    }
940
941                    $s .= $ch;
942                }
943            }
944        }
945
946        decode_error("unexpected end of string while parsing JSON string");
947    }
948
949
950    sub white {
951        while( defined $ch  ){
952            if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){
953                next_chr();
954            }
955            elsif($relaxed and $ch eq '/'){
956                next_chr();
957                if(defined $ch and $ch eq '/'){
958                    1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
959                }
960                elsif(defined $ch and $ch eq '*'){
961                    next_chr();
962                    while(1){
963                        if(defined $ch){
964                            if($ch eq '*'){
965                                if(defined(next_chr()) and $ch eq '/'){
966                                    next_chr();
967                                    last;
968                                }
969                            }
970                            else{
971                                next_chr();
972                            }
973                        }
974                        else{
975                            decode_error("Unterminated comment");
976                        }
977                    }
978                    next;
979                }
980                else{
981                    $at--;
982                    decode_error("malformed JSON string, neither array, object, number, string or atom");
983                }
984            }
985            else{
986                if ($relaxed and $ch eq '#') { # correctly?
987                    pos($text) = $at;
988                    $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
989                    $at = pos($text);
990                    next_chr;
991                    next;
992                }
993
994                last;
995            }
996        }
997    }
998
999
1000    sub array {
1001        my $a  = $_[0] || []; # you can use this code to use another array ref object.
1002
1003        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
1004                                                    if (++$depth > $max_depth);
1005
1006        next_chr();
1007        white();
1008
1009        if(defined $ch and $ch eq ']'){
1010            --$depth;
1011            next_chr();
1012            return $a;
1013        }
1014        else {
1015            while(defined($ch)){
1016                push @$a, value();
1017
1018                white();
1019
1020                if (!defined $ch) {
1021                    last;
1022                }
1023
1024                if($ch eq ']'){
1025                    --$depth;
1026                    next_chr();
1027                    return $a;
1028                }
1029
1030                if($ch ne ','){
1031                    last;
1032                }
1033
1034                next_chr();
1035                white();
1036
1037                if ($relaxed and $ch eq ']') {
1038                    --$depth;
1039                    next_chr();
1040                    return $a;
1041                }
1042
1043            }
1044        }
1045
1046        $at-- if defined $ch and $ch ne '';
1047        decode_error(", or ] expected while parsing array");
1048    }
1049
1050    sub tag {
1051        decode_error('malformed JSON string, neither array, object, number, string or atom') unless $allow_tags;
1052
1053        next_chr();
1054        white();
1055
1056        my $tag = value();
1057        return unless defined $tag;
1058        decode_error('malformed JSON string, (tag) must be a string') if ref $tag;
1059
1060        white();
1061
1062        if (!defined $ch or $ch ne ')') {
1063            decode_error(') expected after tag');
1064        }
1065
1066        next_chr();
1067        white();
1068
1069        my $val = value();
1070        return unless defined $val;
1071        decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY';
1072
1073        if (!eval { $tag->can('THAW') }) {
1074             decode_error('cannot decode perl-object (package does not exist)') if $@;
1075             decode_error('cannot decode perl-object (package does not have a THAW method)');
1076        }
1077        $tag->THAW('JSON', @$val);
1078    }
1079
1080    sub object {
1081        my $o = $_[0] || {}; # you can use this code to use another hash ref object.
1082        my $k;
1083
1084        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
1085                                                if (++$depth > $max_depth);
1086        next_chr();
1087        white();
1088
1089        if(defined $ch and $ch eq '}'){
1090            --$depth;
1091            next_chr();
1092            if ($F_HOOK) {
1093                return _json_object_hook($o);
1094            }
1095            return $o;
1096        }
1097        else {
1098            while (defined $ch) {
1099                $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
1100                white();
1101
1102                if(!defined $ch or $ch ne ':'){
1103                    $at--;
1104                    decode_error("':' expected");
1105                }
1106
1107                next_chr();
1108                $o->{$k} = value();
1109                white();
1110
1111                last if (!defined $ch);
1112
1113                if($ch eq '}'){
1114                    --$depth;
1115                    next_chr();
1116                    if ($F_HOOK) {
1117                        return _json_object_hook($o);
1118                    }
1119                    return $o;
1120                }
1121
1122                if($ch ne ','){
1123                    last;
1124                }
1125
1126                next_chr();
1127                white();
1128
1129                if ($relaxed and $ch eq '}') {
1130                    --$depth;
1131                    next_chr();
1132                    if ($F_HOOK) {
1133                        return _json_object_hook($o);
1134                    }
1135                    return $o;
1136                }
1137
1138            }
1139
1140        }
1141
1142        $at-- if defined $ch and $ch ne '';
1143        decode_error(", or } expected while parsing object/hash");
1144    }
1145
1146
1147    sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
1148        my $key;
1149        while($ch =~ /[\$\w[:^ascii:]]/){
1150            $key .= $ch;
1151            next_chr();
1152        }
1153        return $key;
1154    }
1155
1156
1157    sub word {
1158        my $word =  substr($text,$at-1,4);
1159
1160        if($word eq 'true'){
1161            $at += 3;
1162            next_chr;
1163            return defined $alt_true ? $alt_true : $JSON::PP::true;
1164        }
1165        elsif($word eq 'null'){
1166            $at += 3;
1167            next_chr;
1168            return undef;
1169        }
1170        elsif($word eq 'fals'){
1171            $at += 3;
1172            if(substr($text,$at,1) eq 'e'){
1173                $at++;
1174                next_chr;
1175                return defined $alt_false ? $alt_false : $JSON::PP::false;
1176            }
1177        }
1178
1179        $at--; # for decode_error report
1180
1181        decode_error("'null' expected")  if ($word =~ /^n/);
1182        decode_error("'true' expected")  if ($word =~ /^t/);
1183        decode_error("'false' expected") if ($word =~ /^f/);
1184        decode_error("malformed JSON string, neither array, object, number, string or atom");
1185    }
1186
1187
1188    sub number {
1189        my $n    = '';
1190        my $v;
1191        my $is_dec;
1192        my $is_exp;
1193
1194        if($ch eq '-'){
1195            $n = '-';
1196            next_chr;
1197            if (!defined $ch or $ch !~ /\d/) {
1198                decode_error("malformed number (no digits after initial minus)");
1199            }
1200        }
1201
1202        # According to RFC4627, hex or oct digits are invalid.
1203        if($ch eq '0'){
1204            my $peek = substr($text,$at,1);
1205            if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential)
1206                decode_error("malformed number (leading zero must not be followed by another digit)");
1207            }
1208            $n .= $ch;
1209            next_chr;
1210        }
1211
1212        while(defined $ch and $ch =~ /\d/){
1213            $n .= $ch;
1214            next_chr;
1215        }
1216
1217        if(defined $ch and $ch eq '.'){
1218            $n .= '.';
1219            $is_dec = 1;
1220
1221            next_chr;
1222            if (!defined $ch or $ch !~ /\d/) {
1223                decode_error("malformed number (no digits after decimal point)");
1224            }
1225            else {
1226                $n .= $ch;
1227            }
1228
1229            while(defined(next_chr) and $ch =~ /\d/){
1230                $n .= $ch;
1231            }
1232        }
1233
1234        if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
1235            $n .= $ch;
1236            $is_exp = 1;
1237            next_chr;
1238
1239            if(defined($ch) and ($ch eq '+' or $ch eq '-')){
1240                $n .= $ch;
1241                next_chr;
1242                if (!defined $ch or $ch =~ /\D/) {
1243                    decode_error("malformed number (no digits after exp sign)");
1244                }
1245                $n .= $ch;
1246            }
1247            elsif(defined($ch) and $ch =~ /\d/){
1248                $n .= $ch;
1249            }
1250            else {
1251                decode_error("malformed number (no digits after exp sign)");
1252            }
1253
1254            while(defined(next_chr) and $ch =~ /\d/){
1255                $n .= $ch;
1256            }
1257
1258        }
1259
1260        $v .= $n;
1261
1262        if ($is_dec or $is_exp) {
1263            if ($allow_bignum) {
1264                require Math::BigFloat;
1265                return Math::BigFloat->new($v);
1266            }
1267        } else {
1268            if (length $v > $max_intsize) {
1269                if ($allow_bignum) { # from Adam Sussman
1270                    require Math::BigInt;
1271                    return Math::BigInt->new($v);
1272                }
1273                else {
1274                    return "$v";
1275                }
1276            }
1277        }
1278
1279        return $is_dec ? $v/1.0 : 0+$v;
1280    }
1281
1282    # Compute how many bytes are in the longest legal official Unicode
1283    # character
1284    my $max_unicode_length = do {
1285      no warnings 'utf8';
1286      chr 0x10FFFF;
1287    };
1288    utf8::encode($max_unicode_length);
1289    $max_unicode_length = length $max_unicode_length;
1290
1291    sub is_valid_utf8 {
1292
1293        # Returns undef (setting $utf8_len to 0) unless the next bytes in $text
1294        # comprise a well-formed UTF-8 encoded character, in which case,
1295        # return those bytes, setting $utf8_len to their count.
1296
1297        my $start_point = substr($text, $at - 1);
1298
1299        # Look no further than the maximum number of bytes in a single
1300        # character
1301        my $limit = $max_unicode_length;
1302        $limit = length($start_point) if $limit > length($start_point);
1303
1304        # Find the number of bytes comprising the first character in $text
1305        # (without having to know the details of its internal representation).
1306        # This loop will iterate just once on well-formed input.
1307        while ($limit > 0) {    # Until we succeed or exhaust the input
1308            my $copy = substr($start_point, 0, $limit);
1309
1310            # decode() will return true if all bytes are valid; false
1311            # if any aren't.
1312            if (utf8::decode($copy)) {
1313
1314                # Is valid: get the first character, convert back to bytes,
1315                # and return those bytes.
1316                $copy = substr($copy, 0, 1);
1317                utf8::encode($copy);
1318                $utf8_len = length $copy;
1319                return substr($start_point, 0, $utf8_len);
1320            }
1321
1322            # If it didn't work, it could be that there is a full legal character
1323            # followed by a partial or malformed one.  Narrow the window and
1324            # try again.
1325            $limit--;
1326        }
1327
1328        # Failed to find a legal UTF-8 character.
1329        $utf8_len = 0;
1330        return;
1331    }
1332
1333
1334    sub decode_error {
1335        my $error  = shift;
1336        my $no_rep = shift;
1337        my $str    = defined $text ? substr($text, $at) : '';
1338        my $mess   = '';
1339        my $type   = 'U*';
1340
1341        for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
1342            my $chr_c = chr($c);
1343            $mess .=  $chr_c eq '\\' ? '\\\\'
1344                    : $chr_c =~ /[[:print:]]/ ? $chr_c
1345                    : $chr_c eq '\a' ? '\a'
1346                    : $chr_c eq '\t' ? '\t'
1347                    : $chr_c eq '\n' ? '\n'
1348                    : $chr_c eq '\r' ? '\r'
1349                    : $chr_c eq '\f' ? '\f'
1350                    : sprintf('\x{%x}', $c)
1351                    ;
1352            if ( length $mess >= 20 ) {
1353                $mess .= '...';
1354                last;
1355            }
1356        }
1357
1358        unless ( length $mess ) {
1359            $mess = '(end of string)';
1360        }
1361
1362        Carp::croak (
1363            $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
1364        );
1365
1366    }
1367
1368
1369    sub _json_object_hook {
1370        my $o    = $_[0];
1371        my @ks = keys %{$o};
1372
1373        if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
1374            my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
1375            if (@val == 0) {
1376                return $o;
1377            }
1378            elsif (@val == 1) {
1379                return $val[0];
1380            }
1381            else {
1382                Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar");
1383            }
1384        }
1385
1386        my @val = $cb_object->($o) if ($cb_object);
1387        if (@val == 0) {
1388            return $o;
1389        }
1390        elsif (@val == 1) {
1391            return $val[0];
1392        }
1393        else {
1394            Carp::croak("filter_json_object callbacks must not return more than one scalar");
1395        }
1396    }
1397
1398
1399    sub PP_decode_box {
1400        {
1401            text    => $text,
1402            at      => $at,
1403            ch      => $ch,
1404            len     => $len,
1405            depth   => $depth,
1406            encoding      => $encoding,
1407            is_valid_utf8 => $is_valid_utf8,
1408        };
1409    }
1410
1411} # PARSE
1412
1413
1414sub _decode_surrogates { # from perlunicode
1415    my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
1416    my $un  = pack('U*', $uni);
1417    utf8::encode( $un );
1418    return $un;
1419}
1420
1421
1422sub _decode_unicode {
1423    my $un = pack('U', hex shift);
1424    utf8::encode( $un );
1425    return $un;
1426}
1427
1428sub incr_parse {
1429    local $Carp::CarpLevel = 1;
1430    ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
1431}
1432
1433
1434sub incr_skip {
1435    ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
1436}
1437
1438
1439sub incr_reset {
1440    ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
1441}
1442
1443sub incr_text : lvalue {
1444    $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
1445
1446    if ( $_[0]->{_incr_parser}->{incr_pos} ) {
1447        Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
1448    }
1449    $_[0]->{_incr_parser}->{incr_text};
1450}
1451
1452
1453###############################
1454# Utilities
1455#
1456
1457# shamelessly copied and modified from JSON::XS code.
1458
1459$JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
1460$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1461
1462sub is_bool {
1463  if (blessed $_[0]) {
1464    return (
1465      $_[0]->isa("JSON::PP::Boolean")
1466      or $_[0]->isa("Types::Serialiser::BooleanBase")
1467      or $_[0]->isa("JSON::XS::Boolean")
1468    );
1469  }
1470  elsif (CORE_BOOL) {
1471    BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
1472    return builtin::is_bool($_[0]);
1473  }
1474  return !!0;
1475}
1476
1477sub true  { $JSON::PP::true  }
1478sub false { $JSON::PP::false }
1479sub null  { undef; }
1480
1481###############################
1482
1483package JSON::PP::IncrParser;
1484
1485use strict;
1486
1487use constant INCR_M_WS   => 0; # initial whitespace skipping
1488use constant INCR_M_STR  => 1; # inside string
1489use constant INCR_M_BS   => 2; # inside backslash
1490use constant INCR_M_JSON => 3; # outside anything, count nesting
1491use constant INCR_M_C0   => 4;
1492use constant INCR_M_C1   => 5;
1493use constant INCR_M_TFN  => 6;
1494use constant INCR_M_NUM  => 7;
1495
1496our $VERSION = '1.01';
1497
1498sub new {
1499    my ( $class ) = @_;
1500
1501    bless {
1502        incr_nest    => 0,
1503        incr_text    => undef,
1504        incr_pos     => 0,
1505        incr_mode    => 0,
1506    }, $class;
1507}
1508
1509
1510sub incr_parse {
1511    my ( $self, $coder, $text ) = @_;
1512
1513    $self->{incr_text} = '' unless ( defined $self->{incr_text} );
1514
1515    if ( defined $text ) {
1516        $self->{incr_text} .= $text;
1517    }
1518
1519    if ( defined wantarray ) {
1520        my $max_size = $coder->get_max_size;
1521        my $p = $self->{incr_pos};
1522        my @ret;
1523        {
1524            do {
1525                unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
1526                    $self->_incr_parse( $coder );
1527
1528                    if ( $max_size and $self->{incr_pos} > $max_size ) {
1529                        Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size");
1530                    }
1531                    unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
1532                        # as an optimisation, do not accumulate white space in the incr buffer
1533                        if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) {
1534                            $self->{incr_pos} = 0;
1535                            $self->{incr_text} = '';
1536                        }
1537                        last;
1538                    }
1539                }
1540
1541                unless ( $coder->get_utf8 ) {
1542                    utf8::decode( $self->{incr_text} );
1543                }
1544
1545                my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
1546                push @ret, $obj;
1547                use bytes;
1548                $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 );
1549                $self->{incr_pos} = 0;
1550                $self->{incr_nest} = 0;
1551                $self->{incr_mode} = 0;
1552                last unless wantarray;
1553            } while ( wantarray );
1554        }
1555
1556        if ( wantarray ) {
1557            return @ret;
1558        }
1559        else { # in scalar context
1560            return defined $ret[0] ? $ret[0] : undef;
1561        }
1562    }
1563}
1564
1565
1566sub _incr_parse {
1567    my ($self, $coder) = @_;
1568    my $text = $self->{incr_text};
1569    my $len = length $text;
1570    my $p = $self->{incr_pos};
1571
1572INCR_PARSE:
1573    while ( $len > $p ) {
1574        my $s = substr( $text, $p, 1 );
1575        last INCR_PARSE unless defined $s;
1576        my $mode = $self->{incr_mode};
1577
1578        if ( $mode == INCR_M_WS ) {
1579            while ( $len > $p ) {
1580                $s = substr( $text, $p, 1 );
1581                last INCR_PARSE unless defined $s;
1582                if ( ord($s) > ord " " ) {
1583                    if ( $s eq '#' ) {
1584                        $self->{incr_mode} = INCR_M_C0;
1585                        redo INCR_PARSE;
1586                    } else {
1587                        $self->{incr_mode} = INCR_M_JSON;
1588                        redo INCR_PARSE;
1589                    }
1590                }
1591                $p++;
1592            }
1593        } elsif ( $mode == INCR_M_BS ) {
1594            $p++;
1595            $self->{incr_mode} = INCR_M_STR;
1596            redo INCR_PARSE;
1597        } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) {
1598            while ( $len > $p ) {
1599                $s = substr( $text, $p, 1 );
1600                last INCR_PARSE unless defined $s;
1601                if ( $s eq "\n" ) {
1602                    $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;
1603                    last;
1604                }
1605                $p++;
1606            }
1607            next;
1608        } elsif ( $mode == INCR_M_TFN ) {
1609            last INCR_PARSE if $p >= $len && $self->{incr_nest};
1610            while ( $len > $p ) {
1611                $s = substr( $text, $p++, 1 );
1612                next if defined $s and $s =~ /[rueals]/;
1613                last;
1614            }
1615            $p--;
1616            $self->{incr_mode} = INCR_M_JSON;
1617
1618            last INCR_PARSE unless $self->{incr_nest};
1619            redo INCR_PARSE;
1620        } elsif ( $mode == INCR_M_NUM ) {
1621            last INCR_PARSE if $p >= $len && $self->{incr_nest};
1622            while ( $len > $p ) {
1623                $s = substr( $text, $p++, 1 );
1624                next if defined $s and $s =~ /[0-9eE.+\-]/;
1625                last;
1626            }
1627            $p--;
1628            $self->{incr_mode} = INCR_M_JSON;
1629
1630            last INCR_PARSE unless $self->{incr_nest};
1631            redo INCR_PARSE;
1632        } elsif ( $mode == INCR_M_STR ) {
1633            while ( $len > $p ) {
1634                $s = substr( $text, $p, 1 );
1635                last INCR_PARSE unless defined $s;
1636                if ( $s eq '"' ) {
1637                    $p++;
1638                    $self->{incr_mode} = INCR_M_JSON;
1639
1640                    last INCR_PARSE unless $self->{incr_nest};
1641                    redo INCR_PARSE;
1642                }
1643                elsif ( $s eq '\\' ) {
1644                    $p++;
1645                    if ( !defined substr($text, $p, 1) ) {
1646                        $self->{incr_mode} = INCR_M_BS;
1647                        last INCR_PARSE;
1648                    }
1649                }
1650                $p++;
1651            }
1652        } elsif ( $mode == INCR_M_JSON ) {
1653            while ( $len > $p ) {
1654                $s = substr( $text, $p++, 1 );
1655                if ( $s eq "\x00" ) {
1656                    $p--;
1657                    last INCR_PARSE;
1658                } elsif ( $s =~ /^[\t\n\r ]$/) {
1659                    if ( !$self->{incr_nest} ) {
1660                        $p--; # do not eat the whitespace, let the next round do it
1661                        last INCR_PARSE;
1662                    }
1663                    next;
1664                } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) {
1665                    $self->{incr_mode} = INCR_M_TFN;
1666                    redo INCR_PARSE;
1667                } elsif ( $s =~ /^[0-9\-]$/ ) {
1668                    $self->{incr_mode} = INCR_M_NUM;
1669                    redo INCR_PARSE;
1670                } elsif ( $s eq '"' ) {
1671                    $self->{incr_mode} = INCR_M_STR;
1672                    redo INCR_PARSE;
1673                } elsif ( $s eq '[' or $s eq '{' ) {
1674                    if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
1675                        Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
1676                    }
1677                    next;
1678                } elsif ( $s eq ']' or $s eq '}' ) {
1679                    if ( --$self->{incr_nest} <= 0 ) {
1680                        last INCR_PARSE;
1681                    }
1682                } elsif ( $s eq '#' ) {
1683                    $self->{incr_mode} = INCR_M_C1;
1684                    redo INCR_PARSE;
1685                }
1686            }
1687        }
1688    }
1689
1690    $self->{incr_pos} = $p;
1691    $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility
1692}
1693
1694
1695sub incr_text {
1696    if ( $_[0]->{incr_pos} ) {
1697        Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
1698    }
1699    $_[0]->{incr_text};
1700}
1701
1702
1703sub incr_skip {
1704    my $self  = shift;
1705    $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} );
1706    $self->{incr_pos}     = 0;
1707    $self->{incr_mode}    = 0;
1708    $self->{incr_nest}    = 0;
1709}
1710
1711
1712sub incr_reset {
1713    my $self = shift;
1714    $self->{incr_text}    = undef;
1715    $self->{incr_pos}     = 0;
1716    $self->{incr_mode}    = 0;
1717    $self->{incr_nest}    = 0;
1718}
1719
1720###############################
1721
1722
17231;
1724__END__
1725=pod
1726
1727=head1 NAME
1728
1729JSON::PP - JSON::XS compatible pure-Perl module.
1730
1731=head1 SYNOPSIS
1732
1733 use JSON::PP;
1734
1735 # exported functions, they croak on error
1736 # and expect/generate UTF-8
1737
1738 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
1739 $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
1740
1741 # OO-interface
1742
1743 $json = JSON::PP->new->ascii->pretty->allow_nonref;
1744
1745 $pretty_printed_json_text = $json->encode( $perl_scalar );
1746 $perl_scalar = $json->decode( $json_text );
1747
1748 # Note that JSON version 2.0 and above will automatically use
1749 # JSON::XS or JSON::PP, so you should be able to just:
1750
1751 use JSON;
1752
1753
1754=head1 DESCRIPTION
1755
1756JSON::PP is a pure perl JSON decoder/encoder, and (almost) compatible to much
1757faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as
1758a fallback module when you use L<JSON> module without having
1759installed JSON::XS.
1760
1761Because of this fallback feature of JSON.pm, JSON::PP tries not to
1762be more JavaScript-friendly than JSON::XS (i.e. not to escape extra
1763characters such as U+2028 and U+2029, etc),
1764in order for you not to lose such JavaScript-friendliness silently
1765when you use JSON.pm and install JSON::XS for speed or by accident.
1766If you need JavaScript-friendly RFC7159-compliant pure perl module,
1767try L<JSON::Tiny>, which is derived from L<Mojolicious> web
1768framework and is also smaller and faster than JSON::PP.
1769
1770JSON::PP has been in the Perl core since Perl 5.14, mainly for
1771CPAN toolchain modules to parse META.json.
1772
1773=head1 FUNCTIONAL INTERFACE
1774
1775This section is taken from JSON::XS almost verbatim. C<encode_json>
1776and C<decode_json> are exported by default.
1777
1778=head2 encode_json
1779
1780    $json_text = encode_json $perl_scalar
1781
1782Converts the given Perl data structure to a UTF-8 encoded, binary string
1783(that is, the string contains octets only). Croaks on error.
1784
1785This function call is functionally identical to:
1786
1787    $json_text = JSON::PP->new->utf8->encode($perl_scalar)
1788
1789Except being faster.
1790
1791=head2 decode_json
1792
1793    $perl_scalar = decode_json $json_text
1794
1795The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
1796to parse that as an UTF-8 encoded JSON text, returning the resulting
1797reference. Croaks on error.
1798
1799This function call is functionally identical to:
1800
1801    $perl_scalar = JSON::PP->new->utf8->decode($json_text)
1802
1803Except being faster.
1804
1805=head2 JSON::PP::is_bool
1806
1807    $is_boolean = JSON::PP::is_bool($scalar)
1808
1809Returns true if the passed scalar represents either JSON::PP::true or
1810JSON::PP::false, two constants that act like C<1> and C<0> respectively
1811and are also used to represent JSON C<true> and C<false> in Perl strings.
1812
1813On perl 5.36 and above, will also return true when given one of perl's
1814standard boolean values, such as the result of a comparison.
1815
1816See L<MAPPING>, below, for more information on how JSON values are mapped to
1817Perl.
1818
1819=head1 OBJECT-ORIENTED INTERFACE
1820
1821This section is also taken from JSON::XS.
1822
1823The object oriented interface lets you configure your own encoding or
1824decoding style, within the limits of supported formats.
1825
1826=head2 new
1827
1828    $json = JSON::PP->new
1829
1830Creates a new JSON::PP object that can be used to de/encode JSON
1831strings. All boolean flags described below are by default I<disabled>
1832(with the exception of C<allow_nonref>, which defaults to I<enabled> since
1833version C<4.0>).
1834
1835The mutators for flags all return the JSON::PP object again and thus calls can
1836be chained:
1837
1838   my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
1839   => {"a": [1, 2]}
1840
1841=head2 ascii
1842
1843    $json = $json->ascii([$enable])
1844
1845    $enabled = $json->get_ascii
1846
1847If C<$enable> is true (or missing), then the C<encode> method will not
1848generate characters outside the code range C<0..127> (which is ASCII). Any
1849Unicode characters outside that range will be escaped using either a
1850single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
1851as per RFC4627. The resulting encoded JSON text can be treated as a native
1852Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
1853or any other superset of ASCII.
1854
1855If C<$enable> is false, then the C<encode> method will not escape Unicode
1856characters unless required by the JSON syntax or other flags. This results
1857in a faster and more compact format.
1858
1859See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
1860
1861The main use for this flag is to produce JSON texts that can be
1862transmitted over a 7-bit channel, as the encoded JSON texts will not
1863contain any 8 bit characters.
1864
1865  JSON::PP->new->ascii(1)->encode([chr 0x10401])
1866  => ["\ud801\udc01"]
1867
1868=head2 latin1
1869
1870    $json = $json->latin1([$enable])
1871
1872    $enabled = $json->get_latin1
1873
1874If C<$enable> is true (or missing), then the C<encode> method will encode
1875the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
1876outside the code range C<0..255>. The resulting string can be treated as a
1877latin1-encoded JSON text or a native Unicode string. The C<decode> method
1878will not be affected in any way by this flag, as C<decode> by default
1879expects Unicode, which is a strict superset of latin1.
1880
1881If C<$enable> is false, then the C<encode> method will not escape Unicode
1882characters unless required by the JSON syntax or other flags.
1883
1884See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
1885
1886The main use for this flag is efficiently encoding binary data as JSON
1887text, as most octets will not be escaped, resulting in a smaller encoded
1888size. The disadvantage is that the resulting JSON text is encoded
1889in latin1 (and must correctly be treated as such when storing and
1890transferring), a rare encoding for JSON. It is therefore most useful when
1891you want to store data structures known to contain binary data efficiently
1892in files or databases, not when talking to other JSON encoders/decoders.
1893
1894  JSON::PP->new->latin1->encode (["\x{89}\x{abc}"]
1895  => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
1896
1897=head2 utf8
1898
1899    $json = $json->utf8([$enable])
1900
1901    $enabled = $json->get_utf8
1902
1903If C<$enable> is true (or missing), then the C<encode> method will encode
1904the JSON result into UTF-8, as required by many protocols, while the
1905C<decode> method expects to be handled an UTF-8-encoded string.  Please
1906note that UTF-8-encoded strings do not contain any characters outside the
1907range C<0..255>, they are thus useful for bytewise/binary I/O. In future
1908versions, enabling this option might enable autodetection of the UTF-16
1909and UTF-32 encoding families, as described in RFC4627.
1910
1911If C<$enable> is false, then the C<encode> method will return the JSON
1912string as a (non-encoded) Unicode string, while C<decode> expects thus a
1913Unicode string.  Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs
1914to be done yourself, e.g. using the Encode module.
1915
1916See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
1917
1918Example, output UTF-16BE-encoded JSON:
1919
1920  use Encode;
1921  $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
1922
1923Example, decode UTF-32LE-encoded JSON:
1924
1925  use Encode;
1926  $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
1927
1928=head2 pretty
1929
1930    $json = $json->pretty([$enable])
1931
1932This enables (or disables) all of the C<indent>, C<space_before> and
1933C<space_after> (and in the future possibly more) flags in one call to
1934generate the most readable (or most compact) form possible.
1935
1936=head2 indent
1937
1938    $json = $json->indent([$enable])
1939
1940    $enabled = $json->get_indent
1941
1942If C<$enable> is true (or missing), then the C<encode> method will use a multiline
1943format as output, putting every array member or object/hash key-value pair
1944into its own line, indenting them properly.
1945
1946If C<$enable> is false, no newlines or indenting will be produced, and the
1947resulting JSON text is guaranteed not to contain any C<newlines>.
1948
1949This setting has no effect when decoding JSON texts.
1950
1951The default indent space length is three.
1952You can use C<indent_length> to change the length.
1953
1954=head2 space_before
1955
1956    $json = $json->space_before([$enable])
1957
1958    $enabled = $json->get_space_before
1959
1960If C<$enable> is true (or missing), then the C<encode> method will add an extra
1961optional space before the C<:> separating keys from values in JSON objects.
1962
1963If C<$enable> is false, then the C<encode> method will not add any extra
1964space at those places.
1965
1966This setting has no effect when decoding JSON texts. You will also
1967most likely combine this setting with C<space_after>.
1968
1969Example, space_before enabled, space_after and indent disabled:
1970
1971   {"key" :"value"}
1972
1973=head2 space_after
1974
1975    $json = $json->space_after([$enable])
1976
1977    $enabled = $json->get_space_after
1978
1979If C<$enable> is true (or missing), then the C<encode> method will add an extra
1980optional space after the C<:> separating keys from values in JSON objects
1981and extra whitespace after the C<,> separating key-value pairs and array
1982members.
1983
1984If C<$enable> is false, then the C<encode> method will not add any extra
1985space at those places.
1986
1987This setting has no effect when decoding JSON texts.
1988
1989Example, space_before and indent disabled, space_after enabled:
1990
1991   {"key": "value"}
1992
1993=head2 relaxed
1994
1995    $json = $json->relaxed([$enable])
1996
1997    $enabled = $json->get_relaxed
1998
1999If C<$enable> is true (or missing), then C<decode> will accept some
2000extensions to normal JSON syntax (see below). C<encode> will not be
2001affected in anyway. I<Be aware that this option makes you accept invalid
2002JSON texts as if they were valid!>. I suggest only to use this option to
2003parse application-specific files written by humans (configuration files,
2004resource files etc.)
2005
2006If C<$enable> is false (the default), then C<decode> will only accept
2007valid JSON texts.
2008
2009Currently accepted extensions are:
2010
2011=over 4
2012
2013=item * list items can have an end-comma
2014
2015JSON I<separates> array elements and key-value pairs with commas. This
2016can be annoying if you write JSON texts manually and want to be able to
2017quickly append elements, so this extension accepts comma at the end of
2018such items not just between them:
2019
2020   [
2021      1,
2022      2, <- this comma not normally allowed
2023   ]
2024   {
2025      "k1": "v1",
2026      "k2": "v2", <- this comma not normally allowed
2027   }
2028
2029=item * shell-style '#'-comments
2030
2031Whenever JSON allows whitespace, shell-style comments are additionally
2032allowed. They are terminated by the first carriage-return or line-feed
2033character, after which more white-space and comments are allowed.
2034
2035  [
2036     1, # this comment not allowed in JSON
2037        # neither this one...
2038  ]
2039
2040=item * C-style multiple-line '/* */'-comments (JSON::PP only)
2041
2042Whenever JSON allows whitespace, C-style multiple-line comments are additionally
2043allowed. Everything between C</*> and C<*/> is a comment, after which
2044more white-space and comments are allowed.
2045
2046  [
2047     1, /* this comment not allowed in JSON */
2048        /* neither this one... */
2049  ]
2050
2051=item * C++-style one-line '//'-comments (JSON::PP only)
2052
2053Whenever JSON allows whitespace, C++-style one-line comments are additionally
2054allowed. They are terminated by the first carriage-return or line-feed
2055character, after which more white-space and comments are allowed.
2056
2057  [
2058     1, // this comment not allowed in JSON
2059        // neither this one...
2060  ]
2061
2062=item * literal ASCII TAB characters in strings
2063
2064Literal ASCII TAB characters are now allowed in strings (and treated as
2065C<\t>).
2066
2067  [
2068     "Hello\tWorld",
2069     "Hello<TAB>World", # literal <TAB> would not normally be allowed
2070  ]
2071
2072=back
2073
2074=head2 canonical
2075
2076    $json = $json->canonical([$enable])
2077
2078    $enabled = $json->get_canonical
2079
2080If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
2081by sorting their keys. This is adding a comparatively high overhead.
2082
2083If C<$enable> is false, then the C<encode> method will output key-value
2084pairs in the order Perl stores them (which will likely change between runs
2085of the same script, and can change even within the same run from 5.18
2086onwards).
2087
2088This option is useful if you want the same data structure to be encoded as
2089the same JSON text (given the same overall settings). If it is disabled,
2090the same hash might be encoded differently even if contains the same data,
2091as key-value pairs have no inherent ordering in Perl.
2092
2093This setting has no effect when decoding JSON texts.
2094
2095This setting has currently no effect on tied hashes.
2096
2097=head2 allow_nonref
2098
2099    $json = $json->allow_nonref([$enable])
2100
2101    $enabled = $json->get_allow_nonref
2102
2103Unlike other boolean options, this opotion is enabled by default beginning
2104with version C<4.0>.
2105
2106If C<$enable> is true (or missing), then the C<encode> method can convert a
2107non-reference into its corresponding string, number or null JSON value,
2108which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
2109values instead of croaking.
2110
2111If C<$enable> is false, then the C<encode> method will croak if it isn't
2112passed an arrayref or hashref, as JSON texts must either be an object
2113or array. Likewise, C<decode> will croak if given something that is not a
2114JSON object or array.
2115
2116Example, encode a Perl scalar as JSON value without enabled C<allow_nonref>,
2117resulting in an error:
2118
2119   JSON::PP->new->allow_nonref(0)->encode ("Hello, World!")
2120   => hash- or arrayref expected...
2121
2122=head2 allow_unknown
2123
2124    $json = $json->allow_unknown([$enable])
2125
2126    $enabled = $json->get_allow_unknown
2127
2128If C<$enable> is true (or missing), then C<encode> will I<not> throw an
2129exception when it encounters values it cannot represent in JSON (for
2130example, filehandles) but instead will encode a JSON C<null> value. Note
2131that blessed objects are not included here and are handled separately by
2132c<allow_blessed>.
2133
2134If C<$enable> is false (the default), then C<encode> will throw an
2135exception when it encounters anything it cannot encode as JSON.
2136
2137This option does not affect C<decode> in any way, and it is recommended to
2138leave it off unless you know your communications partner.
2139
2140=head2 allow_blessed
2141
2142    $json = $json->allow_blessed([$enable])
2143
2144    $enabled = $json->get_allow_blessed
2145
2146See L<OBJECT SERIALISATION> for details.
2147
2148If C<$enable> is true (or missing), then the C<encode> method will not
2149barf when it encounters a blessed reference that it cannot convert
2150otherwise. Instead, a JSON C<null> value is encoded instead of the object.
2151
2152If C<$enable> is false (the default), then C<encode> will throw an
2153exception when it encounters a blessed object that it cannot convert
2154otherwise.
2155
2156This setting has no effect on C<decode>.
2157
2158=head2 convert_blessed
2159
2160    $json = $json->convert_blessed([$enable])
2161
2162    $enabled = $json->get_convert_blessed
2163
2164See L<OBJECT SERIALISATION> for details.
2165
2166If C<$enable> is true (or missing), then C<encode>, upon encountering a
2167blessed object, will check for the availability of the C<TO_JSON> method
2168on the object's class. If found, it will be called in scalar context and
2169the resulting scalar will be encoded instead of the object.
2170
2171The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
2172returns other blessed objects, those will be handled in the same
2173way. C<TO_JSON> must take care of not causing an endless recursion cycle
2174(== crash) in this case. The name of C<TO_JSON> was chosen because other
2175methods called by the Perl core (== not by the user of the object) are
2176usually in upper case letters and to avoid collisions with any C<to_json>
2177function or method.
2178
2179If C<$enable> is false (the default), then C<encode> will not consider
2180this type of conversion.
2181
2182This setting has no effect on C<decode>.
2183
2184=head2 allow_tags
2185
2186    $json = $json->allow_tags([$enable])
2187
2188    $enabled = $json->get_allow_tags
2189
2190See L<OBJECT SERIALISATION> for details.
2191
2192If C<$enable> is true (or missing), then C<encode>, upon encountering a
2193blessed object, will check for the availability of the C<FREEZE> method on
2194the object's class. If found, it will be used to serialise the object into
2195a nonstandard tagged JSON value (that JSON decoders cannot decode).
2196
2197It also causes C<decode> to parse such tagged JSON values and deserialise
2198them via a call to the C<THAW> method.
2199
2200If C<$enable> is false (the default), then C<encode> will not consider
2201this type of conversion, and tagged JSON values will cause a parse error
2202in C<decode>, as if tags were not part of the grammar.
2203
2204=head2 boolean_values
2205
2206    $json->boolean_values([$false, $true])
2207
2208    ($false,  $true) = $json->get_boolean_values
2209
2210By default, JSON booleans will be decoded as overloaded
2211C<$JSON::PP::false> and C<$JSON::PP::true> objects.
2212
2213With this method you can specify your own boolean values for decoding -
2214on decode, JSON C<false> will be decoded as a copy of C<$false>, and JSON
2215C<true> will be decoded as C<$true> ("copy" here is the same thing as
2216assigning a value to another variable, i.e. C<$copy = $false>).
2217
2218This is useful when you want to pass a decoded data structure directly
2219to other serialisers like YAML, Data::MessagePack and so on.
2220
2221Note that this works only when you C<decode>. You can set incompatible
2222boolean objects (like L<boolean>), but when you C<encode> a data structure
2223with such boolean objects, you still need to enable C<convert_blessed>
2224(and add a C<TO_JSON> method if necessary).
2225
2226Calling this method without any arguments will reset the booleans
2227to their default values.
2228
2229C<get_boolean_values> will return both C<$false> and C<$true> values, or
2230the empty list when they are set to the default.
2231
2232=head2 core_bools
2233
2234    $json->core_bools([$enable]);
2235
2236If C<$enable> is true (or missing), then C<decode>, will produce standard
2237perl boolean values. Equivalent to calling:
2238
2239    $json->boolean_values(!!1, !!0)
2240
2241C<get_core_bools> will return true if this has been set. On perl 5.36, it will
2242also return true if the boolean values have been set to perl's core booleans
2243using the C<boolean_values> method.
2244
2245The methods C<unblessed_bool> and C<get_unblessed_bool> are provided as aliases
2246for compatibility with L<Cpanel::JSON::XS>.
2247
2248=head2 filter_json_object
2249
2250    $json = $json->filter_json_object([$coderef])
2251
2252When C<$coderef> is specified, it will be called from C<decode> each
2253time it decodes a JSON object. The only argument is a reference to
2254the newly-created hash. If the code references returns a single scalar
2255(which need not be a reference), this value (or rather a copy of it) is
2256inserted into the deserialised data structure. If it returns an empty
2257list (NOTE: I<not> C<undef>, which is a valid scalar), the original
2258deserialised hash will be inserted. This setting can slow down decoding
2259considerably.
2260
2261When C<$coderef> is omitted or undefined, any existing callback will
2262be removed and C<decode> will not change the deserialised hash in any
2263way.
2264
2265Example, convert all JSON objects into the integer 5:
2266
2267   my $js = JSON::PP->new->filter_json_object(sub { 5 });
2268   # returns [5]
2269   $js->decode('[{}]');
2270   # returns 5
2271   $js->decode('{"a":1, "b":2}');
2272
2273=head2 filter_json_single_key_object
2274
2275    $json = $json->filter_json_single_key_object($key [=> $coderef])
2276
2277Works remotely similar to C<filter_json_object>, but is only called for
2278JSON objects having a single key named C<$key>.
2279
2280This C<$coderef> is called before the one specified via
2281C<filter_json_object>, if any. It gets passed the single value in the JSON
2282object. If it returns a single value, it will be inserted into the data
2283structure. If it returns nothing (not even C<undef> but the empty list),
2284the callback from C<filter_json_object> will be called next, as if no
2285single-key callback were specified.
2286
2287If C<$coderef> is omitted or undefined, the corresponding callback will be
2288disabled. There can only ever be one callback for a given key.
2289
2290As this callback gets called less often then the C<filter_json_object>
2291one, decoding speed will not usually suffer as much. Therefore, single-key
2292objects make excellent targets to serialise Perl objects into, especially
2293as single-key JSON objects are as close to the type-tagged value concept
2294as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
2295support this in any way, so you need to make sure your data never looks
2296like a serialised Perl hash.
2297
2298Typical names for the single object key are C<__class_whatever__>, or
2299C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
2300things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
2301with real hashes.
2302
2303Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
2304into the corresponding C<< $WIDGET{<id>} >> object:
2305
2306   # return whatever is in $WIDGET{5}:
2307   JSON::PP
2308      ->new
2309      ->filter_json_single_key_object (__widget__ => sub {
2310            $WIDGET{ $_[0] }
2311         })
2312      ->decode ('{"__widget__": 5')
2313
2314   # this can be used with a TO_JSON method in some "widget" class
2315   # for serialisation to json:
2316   sub WidgetBase::TO_JSON {
2317      my ($self) = @_;
2318
2319      unless ($self->{id}) {
2320         $self->{id} = ..get..some..id..;
2321         $WIDGET{$self->{id}} = $self;
2322      }
2323
2324      { __widget__ => $self->{id} }
2325   }
2326
2327=head2 shrink
2328
2329    $json = $json->shrink([$enable])
2330
2331    $enabled = $json->get_shrink
2332
2333If C<$enable> is true (or missing), the string returned by C<encode> will
2334be shrunk (i.e. downgraded if possible).
2335
2336The actual definition of what shrink does might change in future versions,
2337but it will always try to save space at the expense of time.
2338
2339If C<$enable> is false, then JSON::PP does nothing.
2340
2341=head2 max_depth
2342
2343    $json = $json->max_depth([$maximum_nesting_depth])
2344
2345    $max_depth = $json->get_max_depth
2346
2347Sets the maximum nesting level (default C<512>) accepted while encoding
2348or decoding. If a higher nesting level is detected in JSON text or a Perl
2349data structure, then the encoder and decoder will stop and croak at that
2350point.
2351
2352Nesting level is defined by number of hash- or arrayrefs that the encoder
2353needs to traverse to reach a given point or the number of C<{> or C<[>
2354characters without their matching closing parenthesis crossed to reach a
2355given character in a string.
2356
2357Setting the maximum depth to one disallows any nesting, so that ensures
2358that the object is only a single hash/object or array.
2359
2360If no argument is given, the highest possible setting will be used, which
2361is rarely useful.
2362
2363See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
2364
2365=head2 max_size
2366
2367    $json = $json->max_size([$maximum_string_size])
2368
2369    $max_size = $json->get_max_size
2370
2371Set the maximum length a JSON text may have (in bytes) where decoding is
2372being attempted. The default is C<0>, meaning no limit. When C<decode>
2373is called on a string that is longer then this many bytes, it will not
2374attempt to decode the string but throw an exception. This setting has no
2375effect on C<encode> (yet).
2376
2377If no argument is given, the limit check will be deactivated (same as when
2378C<0> is specified).
2379
2380See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
2381
2382=head2 encode
2383
2384    $json_text = $json->encode($perl_scalar)
2385
2386Converts the given Perl value or data structure to its JSON
2387representation. Croaks on error.
2388
2389=head2 decode
2390
2391    $perl_scalar = $json->decode($json_text)
2392
2393The opposite of C<encode>: expects a JSON text and tries to parse it,
2394returning the resulting simple scalar or reference. Croaks on error.
2395
2396=head2 decode_prefix
2397
2398    ($perl_scalar, $characters) = $json->decode_prefix($json_text)
2399
2400This works like the C<decode> method, but instead of raising an exception
2401when there is trailing garbage after the first JSON object, it will
2402silently stop parsing there and return the number of characters consumed
2403so far.
2404
2405This is useful if your JSON texts are not delimited by an outer protocol
2406and you need to know where the JSON text ends.
2407
2408   JSON::PP->new->decode_prefix ("[1] the tail")
2409   => ([1], 3)
2410
2411=head1 FLAGS FOR JSON::PP ONLY
2412
2413The following flags and properties are for JSON::PP only. If you use
2414any of these, you can't make your application run faster by replacing
2415JSON::PP with JSON::XS. If you need these and also speed boost,
2416you might want to try L<Cpanel::JSON::XS>, a fork of JSON::XS by
2417Reini Urban, which supports some of these (with a different set of
2418incompatibilities). Most of these historical flags are only kept
2419for backward compatibility, and should not be used in a new application.
2420
2421=head2 allow_singlequote
2422
2423    $json = $json->allow_singlequote([$enable])
2424    $enabled = $json->get_allow_singlequote
2425
2426If C<$enable> is true (or missing), then C<decode> will accept
2427invalid JSON texts that contain strings that begin and end with
2428single quotation marks. C<encode> will not be affected in any way.
2429I<Be aware that this option makes you accept invalid JSON texts
2430as if they were valid!>. I suggest only to use this option to
2431parse application-specific files written by humans (configuration
2432files, resource files etc.)
2433
2434If C<$enable> is false (the default), then C<decode> will only accept
2435valid JSON texts.
2436
2437    $json->allow_singlequote->decode(qq|{"foo":'bar'}|);
2438    $json->allow_singlequote->decode(qq|{'foo':"bar"}|);
2439    $json->allow_singlequote->decode(qq|{'foo':'bar'}|);
2440
2441=head2 allow_barekey
2442
2443    $json = $json->allow_barekey([$enable])
2444    $enabled = $json->get_allow_barekey
2445
2446If C<$enable> is true (or missing), then C<decode> will accept
2447invalid JSON texts that contain JSON objects whose names don't
2448begin and end with quotation marks. C<encode> will not be affected
2449in any way. I<Be aware that this option makes you accept invalid JSON
2450texts as if they were valid!>. I suggest only to use this option to
2451parse application-specific files written by humans (configuration
2452files, resource files etc.)
2453
2454If C<$enable> is false (the default), then C<decode> will only accept
2455valid JSON texts.
2456
2457    $json->allow_barekey->decode(qq|{foo:"bar"}|);
2458
2459=head2 allow_bignum
2460
2461    $json = $json->allow_bignum([$enable])
2462    $enabled = $json->get_allow_bignum
2463
2464If C<$enable> is true (or missing), then C<decode> will convert
2465big integers Perl cannot handle as integer into L<Math::BigInt>
2466objects and convert floating numbers into L<Math::BigFloat>
2467objects. C<encode> will convert C<Math::BigInt> and C<Math::BigFloat>
2468objects into JSON numbers.
2469
2470   $json->allow_nonref->allow_bignum;
2471   $bigfloat = $json->decode('2.000000000000000000000000001');
2472   print $json->encode($bigfloat);
2473   # => 2.000000000000000000000000001
2474
2475See also L<MAPPING>.
2476
2477=head2 loose
2478
2479    $json = $json->loose([$enable])
2480    $enabled = $json->get_loose
2481
2482If C<$enable> is true (or missing), then C<decode> will accept
2483invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c]
2484characters. C<encode> will not be affected in any way.
2485I<Be aware that this option makes you accept invalid JSON texts
2486as if they were valid!>. I suggest only to use this option to
2487parse application-specific files written by humans (configuration
2488files, resource files etc.)
2489
2490If C<$enable> is false (the default), then C<decode> will only accept
2491valid JSON texts.
2492
2493    $json->loose->decode(qq|["abc
2494                                   def"]|);
2495
2496=head2 escape_slash
2497
2498    $json = $json->escape_slash([$enable])
2499    $enabled = $json->get_escape_slash
2500
2501If C<$enable> is true (or missing), then C<encode> will explicitly
2502escape I<slash> (solidus; C<U+002F>) characters to reduce the risk of
2503XSS (cross site scripting) that may be caused by C<< </script> >>
2504in a JSON text, with the cost of bloating the size of JSON texts.
2505
2506This option may be useful when you embed JSON in HTML, but embedding
2507arbitrary JSON in HTML (by some HTML template toolkit or by string
2508interpolation) is risky in general. You must escape necessary
2509characters in correct order, depending on the context.
2510
2511C<decode> will not be affected in any way.
2512
2513=head2 indent_length
2514
2515    $json = $json->indent_length($number_of_spaces)
2516    $length = $json->get_indent_length
2517
2518This option is only useful when you also enable C<indent> or C<pretty>.
2519
2520JSON::XS indents with three spaces when you C<encode> (if requested
2521by C<indent> or C<pretty>), and the number cannot be changed.
2522JSON::PP allows you to change/get the number of indent spaces with these
2523mutator/accessor. The default number of spaces is three (the same as
2524JSON::XS), and the acceptable range is from C<0> (no indentation;
2525it'd be better to disable indentation by C<indent(0)>) to C<15>.
2526
2527=head2 sort_by
2528
2529    $json = $json->sort_by($code_ref)
2530    $json = $json->sort_by($subroutine_name)
2531
2532If you just want to sort keys (names) in JSON objects when you
2533C<encode>, enable C<canonical> option (see above) that allows you to
2534sort object keys alphabetically.
2535
2536If you do need to sort non-alphabetically for whatever reasons,
2537you can give a code reference (or a subroutine name) to C<sort_by>,
2538then the argument will be passed to Perl's C<sort> built-in function.
2539
2540As the sorting is done in the JSON::PP scope, you usually need to
2541prepend C<JSON::PP::> to the subroutine name, and the special variables
2542C<$a> and C<$b> used in the subrontine used by C<sort> function.
2543
2544Example:
2545
2546   my %ORDER = (id => 1, class => 2, name => 3);
2547   $json->sort_by(sub {
2548       ($ORDER{$JSON::PP::a} // 999) <=> ($ORDER{$JSON::PP::b} // 999)
2549       or $JSON::PP::a cmp $JSON::PP::b
2550   });
2551   print $json->encode([
2552       {name => 'CPAN', id => 1, href => 'http://cpan.org'}
2553   ]);
2554   # [{"id":1,"name":"CPAN","href":"http://cpan.org"}]
2555
2556Note that C<sort_by> affects all the plain hashes in the data structure.
2557If you need finer control, C<tie> necessary hashes with a module that
2558implements ordered hash (such as L<Hash::Ordered> and L<Tie::IxHash>).
2559C<canonical> and C<sort_by> don't affect the key order in C<tie>d
2560hashes.
2561
2562   use Hash::Ordered;
2563   tie my %hash, 'Hash::Ordered',
2564       (name => 'CPAN', id => 1, href => 'http://cpan.org');
2565   print $json->encode([\%hash]);
2566   # [{"name":"CPAN","id":1,"href":"http://cpan.org"}] # order is kept
2567
2568=head1 INCREMENTAL PARSING
2569
2570This section is also taken from JSON::XS.
2571
2572In some cases, there is the need for incremental parsing of JSON
2573texts. While this module always has to keep both JSON text and resulting
2574Perl data structure in memory at one time, it does allow you to parse a
2575JSON stream incrementally. It does so by accumulating text until it has
2576a full JSON object, which it then can decode. This process is similar to
2577using C<decode_prefix> to see if a full JSON object is available, but
2578is much more efficient (and can be implemented with a minimum of method
2579calls).
2580
2581JSON::PP will only attempt to parse the JSON text once it is sure it
2582has enough text to get a decisive result, using a very simple but
2583truly incremental parser. This means that it sometimes won't stop as
2584early as the full parser, for example, it doesn't detect mismatched
2585parentheses. The only thing it guarantees is that it starts decoding as
2586soon as a syntactically valid JSON text has been seen. This means you need
2587to set resource limits (e.g. C<max_size>) to ensure the parser will stop
2588parsing in the presence if syntax errors.
2589
2590The following methods implement this incremental parser.
2591
2592=head2 incr_parse
2593
2594    $json->incr_parse( [$string] ) # void context
2595
2596    $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
2597
2598    @obj_or_empty = $json->incr_parse( [$string] ) # list context
2599
2600This is the central parsing function. It can both append new text and
2601extract objects from the stream accumulated so far (both of these
2602functions are optional).
2603
2604If C<$string> is given, then this string is appended to the already
2605existing JSON fragment stored in the C<$json> object.
2606
2607After that, if the function is called in void context, it will simply
2608return without doing anything further. This can be used to add more text
2609in as many chunks as you want.
2610
2611If the method is called in scalar context, then it will try to extract
2612exactly I<one> JSON object. If that is successful, it will return this
2613object, otherwise it will return C<undef>. If there is a parse error,
2614this method will croak just as C<decode> would do (one can then use
2615C<incr_skip> to skip the erroneous part). This is the most common way of
2616using the method.
2617
2618And finally, in list context, it will try to extract as many objects
2619from the stream as it can find and return them, or the empty list
2620otherwise. For this to work, there must be no separators (other than
2621whitespace) between the JSON objects or arrays, instead they must be
2622concatenated back-to-back. If an error occurs, an exception will be
2623raised as in the scalar context case. Note that in this case, any
2624previously-parsed JSON texts will be lost.
2625
2626Example: Parse some JSON arrays/objects in a given string and return
2627them.
2628
2629    my @objs = JSON::PP->new->incr_parse ("[5][7][1,2]");
2630
2631=head2 incr_text
2632
2633    $lvalue_string = $json->incr_text
2634
2635This method returns the currently stored JSON fragment as an lvalue, that
2636is, you can manipulate it. This I<only> works when a preceding call to
2637C<incr_parse> in I<scalar context> successfully returned an object. Under
2638all other circumstances you must not call this function (I mean it.
2639although in simple tests it might actually work, it I<will> fail under
2640real world conditions). As a special exception, you can also call this
2641method before having parsed anything.
2642
2643That means you can only use this function to look at or manipulate text
2644before or after complete JSON objects, not while the parser is in the
2645middle of parsing a JSON object.
2646
2647This function is useful in two cases: a) finding the trailing text after a
2648JSON object or b) parsing multiple JSON objects separated by non-JSON text
2649(such as commas).
2650
2651=head2 incr_skip
2652
2653    $json->incr_skip
2654
2655This will reset the state of the incremental parser and will remove
2656the parsed text from the input buffer so far. This is useful after
2657C<incr_parse> died, in which case the input buffer and incremental parser
2658state is left unchanged, to skip the text parsed so far and to reset the
2659parse state.
2660
2661The difference to C<incr_reset> is that only text until the parse error
2662occurred is removed.
2663
2664=head2 incr_reset
2665
2666    $json->incr_reset
2667
2668This completely resets the incremental parser, that is, after this call,
2669it will be as if the parser had never parsed anything.
2670
2671This is useful if you want to repeatedly parse JSON objects and want to
2672ignore any trailing data, which means you have to reset the parser after
2673each successful decode.
2674
2675=head1 MAPPING
2676
2677Most of this section is also taken from JSON::XS.
2678
2679This section describes how JSON::PP maps Perl values to JSON values and
2680vice versa. These mappings are designed to "do the right thing" in most
2681circumstances automatically, preserving round-tripping characteristics
2682(what you put in comes out as something equivalent).
2683
2684For the more enlightened: note that in the following descriptions,
2685lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
2686refers to the abstract Perl language itself.
2687
2688=head2 JSON -> PERL
2689
2690=over 4
2691
2692=item object
2693
2694A JSON object becomes a reference to a hash in Perl. No ordering of object
2695keys is preserved (JSON does not preserve object key ordering itself).
2696
2697=item array
2698
2699A JSON array becomes a reference to an array in Perl.
2700
2701=item string
2702
2703A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
2704are represented by the same codepoints in the Perl string, so no manual
2705decoding is necessary.
2706
2707=item number
2708
2709A JSON number becomes either an integer, numeric (floating point) or
2710string scalar in perl, depending on its range and any fractional parts. On
2711the Perl level, there is no difference between those as Perl handles all
2712the conversion details, but an integer may take slightly less memory and
2713might represent more values exactly than floating point numbers.
2714
2715If the number consists of digits only, JSON::PP will try to represent
2716it as an integer value. If that fails, it will try to represent it as
2717a numeric (floating point) value if that is possible without loss of
2718precision. Otherwise it will preserve the number as a string value (in
2719which case you lose roundtripping ability, as the JSON number will be
2720re-encoded to a JSON string).
2721
2722Numbers containing a fractional or exponential part will always be
2723represented as numeric (floating point) values, possibly at a loss of
2724precision (in which case you might lose perfect roundtripping ability, but
2725the JSON number will still be re-encoded as a JSON number).
2726
2727Note that precision is not accuracy - binary floating point values cannot
2728represent most decimal fractions exactly, and when converting from and to
2729floating point, JSON::PP only guarantees precision up to but not including
2730the least significant bit.
2731
2732When C<allow_bignum> is enabled, big integer values and any numeric
2733values will be converted into L<Math::BigInt> and L<Math::BigFloat>
2734objects respectively, without becoming string scalars or losing
2735precision.
2736
2737=item true, false
2738
2739These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
2740respectively. They are overloaded to act almost exactly like the numbers
2741C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
2742the C<JSON::PP::is_bool> function.
2743
2744=item null
2745
2746A JSON null atom becomes C<undef> in Perl.
2747
2748=item shell-style comments (C<< # I<text> >>)
2749
2750As a nonstandard extension to the JSON syntax that is enabled by the
2751C<relaxed> setting, shell-style comments are allowed. They can start
2752anywhere outside strings and go till the end of the line.
2753
2754=item tagged values (C<< (I<tag>)I<value> >>).
2755
2756Another nonstandard extension to the JSON syntax, enabled with the
2757C<allow_tags> setting, are tagged values. In this implementation, the
2758I<tag> must be a perl package/class name encoded as a JSON string, and the
2759I<value> must be a JSON array encoding optional constructor arguments.
2760
2761See L<OBJECT SERIALISATION>, below, for details.
2762
2763=back
2764
2765
2766=head2 PERL -> JSON
2767
2768The mapping from Perl to JSON is slightly more difficult, as Perl is a
2769truly typeless language, so we can only guess which JSON type is meant by
2770a Perl value.
2771
2772=over 4
2773
2774=item hash references
2775
2776Perl hash references become JSON objects. As there is no inherent
2777ordering in hash keys (or JSON objects), they will usually be encoded
2778in a pseudo-random order. JSON::PP can optionally sort the hash keys
2779(determined by the I<canonical> flag and/or I<sort_by> property), so
2780the same data structure will serialise to the same JSON text (given
2781same settings and version of JSON::PP), but this incurs a runtime
2782overhead and is only rarely useful, e.g. when you want to compare some
2783JSON text against another for equality.
2784
2785=item array references
2786
2787Perl array references become JSON arrays.
2788
2789=item other references
2790
2791Other unblessed references are generally not allowed and will cause an
2792exception to be thrown, except for references to the integers C<0> and
2793C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
2794also use C<JSON::PP::false> and C<JSON::PP::true> to improve
2795readability.
2796
2797   to_json [\0, JSON::PP::true]      # yields [false,true]
2798
2799=item JSON::PP::true, JSON::PP::false
2800
2801These special values become JSON true and JSON false values,
2802respectively. You can also use C<\1> and C<\0> directly if you want.
2803
2804=item JSON::PP::null
2805
2806This special value becomes JSON null.
2807
2808=item blessed objects
2809
2810Blessed objects are not directly representable in JSON, but C<JSON::PP>
2811allows various ways of handling objects. See L<OBJECT SERIALISATION>,
2812below, for details.
2813
2814=item simple scalars
2815
2816Simple Perl scalars (any scalar that is not a reference) are the most
2817difficult objects to encode: JSON::PP will encode undefined scalars as
2818JSON C<null> values, scalars that have last been used in a string context
2819before encoding as JSON strings, and anything else as number value:
2820
2821   # dump as number
2822   encode_json [2]                      # yields [2]
2823   encode_json [-3.0e17]                # yields [-3e+17]
2824   my $value = 5; encode_json [$value]  # yields [5]
2825
2826   # used as string, so dump as string
2827   print $value;
2828   encode_json [$value]                 # yields ["5"]
2829
2830   # undef becomes null
2831   encode_json [undef]                  # yields [null]
2832
2833You can force the type to be a JSON string by stringifying it:
2834
2835   my $x = 3.1; # some variable containing a number
2836   "$x";        # stringified
2837   $x .= "";    # another, more awkward way to stringify
2838   print $x;    # perl does it for you, too, quite often
2839                # (but for older perls)
2840
2841You can force the type to be a JSON number by numifying it:
2842
2843   my $x = "3"; # some variable containing a string
2844   $x += 0;     # numify it, ensuring it will be dumped as a number
2845   $x *= 1;     # same thing, the choice is yours.
2846
2847You can not currently force the type in other, less obscure, ways.
2848
2849Since version 2.91_01, JSON::PP uses a different number detection logic
2850that converts a scalar that is possible to turn into a number safely.
2851The new logic is slightly faster, and tends to help people who use older
2852perl or who want to encode complicated data structure. However, this may
2853results in a different JSON text from the one JSON::XS encodes (and
2854thus may break tests that compare entire JSON texts). If you do
2855need the previous behavior for compatibility or for finer control,
2856set PERL_JSON_PP_USE_B environmental variable to true before you
2857C<use> JSON::PP (or JSON.pm).
2858
2859Note that numerical precision has the same meaning as under Perl (so
2860binary to decimal conversion follows the same rules as in Perl, which
2861can differ to other languages). Also, your perl interpreter might expose
2862extensions to the floating point numbers of your platform, such as
2863infinities or NaN's - these cannot be represented in JSON, and it is an
2864error to pass those in.
2865
2866JSON::PP (and JSON::XS) trusts what you pass to C<encode> method
2867(or C<encode_json> function) is a clean, validated data structure with
2868values that can be represented as valid JSON values only, because it's
2869not from an external data source (as opposed to JSON texts you pass to
2870C<decode> or C<decode_json>, which JSON::PP considers tainted and
2871doesn't trust). As JSON::PP doesn't know exactly what you and consumers
2872of your JSON texts want the unexpected values to be (you may want to
2873convert them into null, or to stringify them with or without
2874normalisation (string representation of infinities/NaN may vary
2875depending on platforms), or to croak without conversion), you're advised
2876to do what you and your consumers need before you encode, and also not
2877to numify values that may start with values that look like a number
2878(including infinities/NaN), without validating.
2879
2880=back
2881
2882=head2 OBJECT SERIALISATION
2883
2884As JSON cannot directly represent Perl objects, you have to choose between
2885a pure JSON representation (without the ability to deserialise the object
2886automatically again), and a nonstandard extension to the JSON syntax,
2887tagged values.
2888
2889=head3 SERIALISATION
2890
2891What happens when C<JSON::PP> encounters a Perl object depends on the
2892C<allow_blessed>, C<convert_blessed>, C<allow_tags> and C<allow_bignum>
2893settings, which are used in this order:
2894
2895=over 4
2896
2897=item 1. C<allow_tags> is enabled and the object has a C<FREEZE> method.
2898
2899In this case, C<JSON::PP> creates a tagged JSON value, using a nonstandard
2900extension to the JSON syntax.
2901
2902This works by invoking the C<FREEZE> method on the object, with the first
2903argument being the object to serialise, and the second argument being the
2904constant string C<JSON> to distinguish it from other serialisers.
2905
2906The C<FREEZE> method can return any number of values (i.e. zero or
2907more). These values and the paclkage/classname of the object will then be
2908encoded as a tagged JSON value in the following format:
2909
2910   ("classname")[FREEZE return values...]
2911
2912e.g.:
2913
2914   ("URI")["http://www.google.com/"]
2915   ("MyDate")[2013,10,29]
2916   ("ImageData::JPEG")["Z3...VlCg=="]
2917
2918For example, the hypothetical C<My::Object> C<FREEZE> method might use the
2919objects C<type> and C<id> members to encode the object:
2920
2921   sub My::Object::FREEZE {
2922      my ($self, $serialiser) = @_;
2923
2924      ($self->{type}, $self->{id})
2925   }
2926
2927=item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
2928
2929In this case, the C<TO_JSON> method of the object is invoked in scalar
2930context. It must return a single scalar that can be directly encoded into
2931JSON. This scalar replaces the object in the JSON text.
2932
2933For example, the following C<TO_JSON> method will convert all L<URI>
2934objects to JSON strings when serialised. The fact that these values
2935originally were L<URI> objects is lost.
2936
2937   sub URI::TO_JSON {
2938      my ($uri) = @_;
2939      $uri->as_string
2940   }
2941
2942=item 3. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>.
2943
2944The object will be serialised as a JSON number value.
2945
2946=item 4. C<allow_blessed> is enabled.
2947
2948The object will be serialised as a JSON null value.
2949
2950=item 5. none of the above
2951
2952If none of the settings are enabled or the respective methods are missing,
2953C<JSON::PP> throws an exception.
2954
2955=back
2956
2957=head3 DESERIALISATION
2958
2959For deserialisation there are only two cases to consider: either
2960nonstandard tagging was used, in which case C<allow_tags> decides,
2961or objects cannot be automatically be deserialised, in which
2962case you can use postprocessing or the C<filter_json_object> or
2963C<filter_json_single_key_object> callbacks to get some real objects our of
2964your JSON.
2965
2966This section only considers the tagged value case: a tagged JSON object
2967is encountered during decoding and C<allow_tags> is disabled, a parse
2968error will result (as if tagged values were not part of the grammar).
2969
2970If C<allow_tags> is enabled, C<JSON::PP> will look up the C<THAW> method
2971of the package/classname used during serialisation (it will not attempt
2972to load the package as a Perl module). If there is no such method, the
2973decoding will fail with an error.
2974
2975Otherwise, the C<THAW> method is invoked with the classname as first
2976argument, the constant string C<JSON> as second argument, and all the
2977values from the JSON array (the values originally returned by the
2978C<FREEZE> method) as remaining arguments.
2979
2980The method must then return the object. While technically you can return
2981any Perl scalar, you might have to enable the C<allow_nonref> setting to
2982make that work in all cases, so better return an actual blessed reference.
2983
2984As an example, let's implement a C<THAW> function that regenerates the
2985C<My::Object> from the C<FREEZE> example earlier:
2986
2987   sub My::Object::THAW {
2988      my ($class, $serialiser, $type, $id) = @_;
2989
2990      $class->new (type => $type, id => $id)
2991   }
2992
2993
2994=head1 ENCODING/CODESET FLAG NOTES
2995
2996This section is taken from JSON::XS.
2997
2998The interested reader might have seen a number of flags that signify
2999encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
3000some confusion on what these do, so here is a short comparison:
3001
3002C<utf8> controls whether the JSON text created by C<encode> (and expected
3003by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
3004control whether C<encode> escapes character values outside their respective
3005codeset range. Neither of these flags conflict with each other, although
3006some combinations make less sense than others.
3007
3008Care has been taken to make all flags symmetrical with respect to
3009C<encode> and C<decode>, that is, texts encoded with any combination of
3010these flag values will be correctly decoded when the same flags are used
3011- in general, if you use different flag settings while encoding vs. when
3012decoding you likely have a bug somewhere.
3013
3014Below comes a verbose discussion of these flags. Note that a "codeset" is
3015simply an abstract set of character-codepoint pairs, while an encoding
3016takes those codepoint numbers and I<encodes> them, in our case into
3017octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
3018and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
3019the same time, which can be confusing.
3020
3021=over 4
3022
3023=item C<utf8> flag disabled
3024
3025When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
3026and expect Unicode strings, that is, characters with high ordinal Unicode
3027values (> 255) will be encoded as such characters, and likewise such
3028characters are decoded as-is, no changes to them will be done, except
3029"(re-)interpreting" them as Unicode codepoints or Unicode characters,
3030respectively (to Perl, these are the same thing in strings unless you do
3031funny/weird/dumb stuff).
3032
3033This is useful when you want to do the encoding yourself (e.g. when you
3034want to have UTF-16 encoded JSON texts) or when some other layer does
3035the encoding for you (for example, when printing to a terminal using a
3036filehandle that transparently encodes to UTF-8 you certainly do NOT want
3037to UTF-8 encode your data first and have Perl encode it another time).
3038
3039=item C<utf8> flag enabled
3040
3041If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
3042characters using the corresponding UTF-8 multi-byte sequence, and will
3043expect your input strings to be encoded as UTF-8, that is, no "character"
3044of the input string must have any value > 255, as UTF-8 does not allow
3045that.
3046
3047The C<utf8> flag therefore switches between two modes: disabled means you
3048will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
3049octet/binary string in Perl.
3050
3051=item C<latin1> or C<ascii> flags enabled
3052
3053With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
3054with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
3055characters as specified by the C<utf8> flag.
3056
3057If C<utf8> is disabled, then the result is also correctly encoded in those
3058character sets (as both are proper subsets of Unicode, meaning that a
3059Unicode string with all character values < 256 is the same thing as a
3060ISO-8859-1 string, and a Unicode string with all character values < 128 is
3061the same thing as an ASCII string in Perl).
3062
3063If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
3064regardless of these flags, just some more characters will be escaped using
3065C<\uXXXX> then before.
3066
3067Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
3068encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
3069encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
3070a subset of Unicode), while ASCII is.
3071
3072Surprisingly, C<decode> will ignore these flags and so treat all input
3073values as governed by the C<utf8> flag. If it is disabled, this allows you
3074to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
3075Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
3076
3077So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
3078they only govern when the JSON output engine escapes a character or not.
3079
3080The main use for C<latin1> is to relatively efficiently store binary data
3081as JSON, at the expense of breaking compatibility with most JSON decoders.
3082
3083The main use for C<ascii> is to force the output to not contain characters
3084with values > 127, which means you can interpret the resulting string
3085as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
30868-bit-encoding, and still get the same data structure back. This is useful
3087when your channel for JSON transfer is not 8-bit clean or the encoding
3088might be mangled in between (e.g. in mail), and works because ASCII is a
3089proper subset of most 8-bit and multibyte encodings in use in the world.
3090
3091=back
3092
3093=head1 BUGS
3094
3095Please report bugs on a specific behavior of this module to RT or GitHub
3096issues (preferred):
3097
3098L<https://github.com/makamaka/JSON-PP/issues>
3099
3100L<https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON-PP>
3101
3102As for new features and requests to change common behaviors, please
3103ask the author of JSON::XS (Marc Lehmann, E<lt>schmorp[at]schmorp.deE<gt>)
3104first, by email (important!), to keep compatibility among JSON.pm backends.
3105
3106Generally speaking, if you need something special for you, you are advised
3107to create a new module, maybe based on L<JSON::Tiny>, which is smaller and
3108written in a much cleaner way than this module.
3109
3110=head1 SEE ALSO
3111
3112The F<json_pp> command line utility for quick experiments.
3113
3114L<JSON::XS>, L<Cpanel::JSON::XS>, and L<JSON::Tiny> for faster alternatives.
3115L<JSON> and L<JSON::MaybeXS> for easy migration.
3116
3117L<JSON::PP::Compat5005> and L<JSON::PP::Compat5006> for older perl users.
3118
3119RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
3120
3121RFC7159 (L<http://www.ietf.org/rfc/rfc7159.txt>)
3122
3123RFC8259 (L<http://www.ietf.org/rfc/rfc8259.txt>)
3124
3125=head1 AUTHOR
3126
3127Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
3128
3129=head1 CURRENT MAINTAINER
3130
3131Kenichi Ishigaki, E<lt>ishigaki[at]cpan.orgE<gt>
3132
3133=head1 COPYRIGHT AND LICENSE
3134
3135Copyright 2007-2016 by Makamaka Hannyaharamitu
3136
3137Most of the documentation is taken from JSON::XS by Marc Lehmann
3138
3139This library is free software; you can redistribute it and/or modify
3140it under the same terms as Perl itself.
3141
3142=cut
3143