root/main/trunk/greenstone2/perllib/cpan/JSON/PP.pm @ 31781

Revision 31781, 58.7 KB (checked in by ak19, 3 years ago)

Adding in patches to cpan perl code as required to get the remote greenstone server to still work with perl v 5.22.1. Not tested these changes with out usual perl 5.18. I'm not getting a newer version of these modules from CPAN since I'm not sure whether there may be some compatibility issues of the newer versions with our existing code. So I'm making the smallest number of changes that will keep our code still working.

  • Property svn:executable set to *
Line 
1package JSON::PP;
2
3# JSON-2.0
4
5use 5.005;
6use strict;
7use base qw(Exporter);
8use overload ();
9
10use Carp ();
11use B ();
12#use Devel::Peek;
13
14$JSON::PP::VERSION = '2.27008';
15
16@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
17
18# instead of hash-access, i tried index-access for speed.
19# but this method is not faster than what i expected. so it will be changed.
20
21use constant P_ASCII                => 0;
22use constant P_LATIN1               => 1;
23use constant P_UTF8                 => 2;
24use constant P_INDENT               => 3;
25use constant P_CANONICAL            => 4;
26use constant P_SPACE_BEFORE         => 5;
27use constant P_SPACE_AFTER          => 6;
28use constant P_ALLOW_NONREF         => 7;
29use constant P_SHRINK               => 8;
30use constant P_ALLOW_BLESSED        => 9;
31use constant P_CONVERT_BLESSED      => 10;
32use constant P_RELAXED              => 11;
33
34use constant P_LOOSE                => 12;
35use constant P_ALLOW_BIGNUM         => 13;
36use constant P_ALLOW_BAREKEY        => 14;
37use constant P_ALLOW_SINGLEQUOTE    => 15;
38use constant P_ESCAPE_SLASH         => 16;
39use constant P_AS_NONBLESSED        => 17;
40
41use constant P_ALLOW_UNKNOWN        => 18;
42
43use constant OLD_PERL => $] < 5.008 ? 1 : 0;
44
45BEGIN {
46    my @xs_compati_bit_properties = qw(
47            latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
48            allow_blessed convert_blessed relaxed allow_unknown
49    );
50    my @pp_bit_properties = qw(
51            allow_singlequote allow_bignum loose
52            allow_barekey escape_slash as_nonblessed
53    );
54
55    # Perl version check, Unicode handling is enable?
56    # Helper module sets @JSON::PP::_properties.
57
58    my $helper = $] >= 5.008 ? 'JSON::PP58'
59               : $] >= 5.006 ? 'JSON::PP56'
60               :               'JSON::PP5005'
61               ;
62
63    eval qq| require $helper |;
64    if ($@) { Carp::croak $@; }
65
66    for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
67        my $flag_name = 'P_' . uc($name);
68
69        eval qq/
70            sub $name {
71                my \$enable = defined \$_[1] ? \$_[1] : 1;
72
73                if (\$enable) {
74                    \$_[0]->{PROPS}->[$flag_name] = 1;
75                }
76                else {
77                    \$_[0]->{PROPS}->[$flag_name] = 0;
78                }
79
80                \$_[0];
81            }
82
83            sub get_$name {
84                \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
85            }
86        /;
87    }
88
89}
90
91
92
93# Functions
94
95my %encode_allow_method
96     = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
97                          allow_blessed convert_blessed indent indent_length allow_bignum
98                          as_nonblessed
99                        /;
100my %decode_allow_method
101     = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
102                          allow_barekey max_size relaxed/;
103
104
105my $JSON; # cache
106
107sub encode_json ($) { # encode
108    ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
109}
110
111
112sub decode_json { # decode
113    ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
114}
115
116# Obsoleted
117
118sub to_json($) {
119   Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
120}
121
122
123sub from_json($) {
124   Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
125}
126
127
128# Methods
129
130sub new {
131    my $class = shift;
132    my $self  = {
133        max_depth   => 512,
134        max_size    => 0,
135        indent      => 0,
136        FLAGS       => 0,
137        fallback      => sub { encode_error('Invalid value. JSON can only reference.') },
138        indent_length => 3,
139    };
140
141    bless $self, $class;
142}
143
144
145sub encode {
146    return $_[0]->PP_encode_json($_[1]);
147}
148
149
150sub decode {
151    return $_[0]->PP_decode_json($_[1], 0x00000000);
152}
153
154
155sub decode_prefix {
156    return $_[0]->PP_decode_json($_[1], 0x00000001);
157}
158
159
160# accessor
161
162
163# pretty printing
164
165sub pretty {
166    my ($self, $v) = @_;
167    my $enable = defined $v ? $v : 1;
168
169    if ($enable) { # indent_length(3) for JSON::XS compatibility
170        $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
171    }
172    else {
173        $self->indent(0)->space_before(0)->space_after(0);
174    }
175
176    $self;
177}
178
179# etc
180
181sub max_depth {
182    my $max  = defined $_[1] ? $_[1] : 0x80000000;
183    $_[0]->{max_depth} = $max;
184    $_[0];
185}
186
187
188sub get_max_depth { $_[0]->{max_depth}; }
189
190
191sub max_size {
192    my $max  = defined $_[1] ? $_[1] : 0;
193    $_[0]->{max_size} = $max;
194    $_[0];
195}
196
197
198sub get_max_size { $_[0]->{max_size}; }
199
200
201sub filter_json_object {
202    $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
203    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
204    $_[0];
205}
206
207sub filter_json_single_key_object {
208    if (@_ > 1) {
209        $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
210    }
211    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
212    $_[0];
213}
214
215sub indent_length {
216    if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
217        Carp::carp "The acceptable range of indent_length() is 0 to 15.";
218    }
219    else {
220        $_[0]->{indent_length} = $_[1];
221    }
222    $_[0];
223}
224
225sub get_indent_length {
226    $_[0]->{indent_length};
227}
228
229sub sort_by {
230    $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
231    $_[0];
232}
233
234sub allow_bigint {
235    Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
236}
237
238###############################
239
240###
241### Perl => JSON
242###
243
244
245{ # Convert
246
247    my $max_depth;
248    my $indent;
249    my $ascii;
250    my $latin1;
251    my $utf8;
252    my $space_before;
253    my $space_after;
254    my $canonical;
255    my $allow_blessed;
256    my $convert_blessed;
257
258    my $indent_length;
259    my $escape_slash;
260    my $bignum;
261    my $as_nonblessed;
262
263    my $depth;
264    my $indent_count;
265    my $keysort;
266
267
268    sub PP_encode_json {
269        my $self = shift;
270        my $obj  = shift;
271
272        $indent_count = 0;
273        $depth        = 0;
274
275        my $idx = $self->{PROPS};
276
277        ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
278            $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
279         = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
280                    P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
281
282        ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
283
284        $keysort = $canonical ? sub { $a cmp $b } : undef;
285
286        if ($self->{sort_by}) {
287            $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
288                     : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
289                     : sub { $a cmp $b };
290        }
291
292        encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
293             if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
294
295        my $str  = $self->object_to_json($obj);
296
297        $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
298
299        unless ($ascii or $latin1 or $utf8) {
300            utf8::upgrade($str);
301        }
302
303        if ($idx->[ P_SHRINK ]) {
304            utf8::downgrade($str, 1);
305        }
306
307        return $str;
308    }
309
310
311    sub object_to_json {
312        my ($self, $obj) = @_;
313        my $type = ref($obj);
314
315        if($type eq 'HASH'){
316            return $self->hash_to_json($obj);
317        }
318        elsif($type eq 'ARRAY'){
319            return $self->array_to_json($obj);
320        }
321        elsif ($type) { # blessed object?
322            if (blessed($obj)) {
323
324                return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
325
326                if ( $convert_blessed and $obj->can('TO_JSON') ) {
327                    my $result = $obj->TO_JSON();
328                    if ( defined $result and overload::Overloaded( $obj ) ) {
329                        if ( overload::StrVal( $obj ) eq $result ) {
330                            encode_error( sprintf(
331                                "%s::TO_JSON method returned same object as was passed instead of a new one",
332                                ref $obj
333                            ) );
334                        }
335                    }
336
337                    return $self->object_to_json( $result );
338                }
339
340                return "$obj" if ( $bignum and _is_bignum($obj) );
341                return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
342
343                encode_error( sprintf("encountered object '%s', but neither allow_blessed "
344                    . "nor convert_blessed settings are enabled", $obj)
345                ) unless ($allow_blessed);
346
347                return 'null';
348            }
349            else {
350                return $self->value_to_json($obj);
351            }
352        }
353        else{
354            return $self->value_to_json($obj);
355        }
356    }
357
358
359    sub hash_to_json {
360        my ($self, $obj) = @_;
361        my @res;
362
363        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
364                                         if (++$depth > $max_depth);
365
366        my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
367        my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
368
369        for my $k ( _sort( $obj ) ) {
370            if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
371            push @res, string_to_json( $self, $k )
372                          .  $del
373                          . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
374        }
375
376        --$depth;
377        $self->_down_indent() if ($indent);
378
379        return   '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' )  . '}';
380    }
381
382
383    sub array_to_json {
384        my ($self, $obj) = @_;
385        my @res;
386
387        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
388                                         if (++$depth > $max_depth);
389
390        my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
391
392        for my $v (@$obj){
393            push @res, $self->object_to_json($v) || $self->value_to_json($v);
394        }
395
396        --$depth;
397        $self->_down_indent() if ($indent);
398
399        return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
400    }
401
402
403    sub value_to_json {
404        my ($self, $value) = @_;
405
406        return 'null' if(!defined $value);
407
408        my $b_obj = B::svref_2object(\$value);  # for round trip problem
409        my $flags = $b_obj->FLAGS;
410
411        return $value # as is
412            if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
413
414        my $type = ref($value);
415
416        if(!$type){
417            return string_to_json($self, $value);
418        }
419        elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
420            return $$value == 1 ? 'true' : 'false';
421        }
422        elsif ($type) {
423            if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
424                return $self->value_to_json("$value");
425            }
426
427            if ($type eq 'SCALAR' and defined $$value) {
428                return   $$value eq '1' ? 'true'
429                       : $$value eq '0' ? 'false'
430                       : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
431                       : encode_error("cannot encode reference to scalar");
432            }
433
434             if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
435                 return 'null';
436             }
437             else {
438                 if ( $type eq 'SCALAR' or $type eq 'REF' ) {
439                    encode_error("cannot encode reference to scalar");
440                 }
441                 else {
442                    encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
443                 }
444             }
445
446        }
447        else {
448            return $self->{fallback}->($value)
449                 if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
450            return 'null';
451        }
452
453    }
454
455
456    my %esc = (
457        "\n" => '\n',
458        "\r" => '\r',
459        "\t" => '\t',
460        "\f" => '\f',
461        "\b" => '\b',
462        "\"" => '\"',
463        "\\" => '\\\\',
464        "\'" => '\\\'',
465    );
466
467
468    sub string_to_json {
469        my ($self, $arg) = @_;
470
471        $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
472        $arg =~ s/\//\\\//g if ($escape_slash);
473        $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
474
475        if ($ascii) {
476            $arg = JSON_PP_encode_ascii($arg);
477        }
478
479        if ($latin1) {
480            $arg = JSON_PP_encode_latin1($arg);
481        }
482
483        if ($utf8) {
484            utf8::encode($arg);
485        }
486
487        return '"' . $arg . '"';
488    }
489
490
491    sub blessed_to_json {
492        my $reftype = reftype($_[1]) || '';
493        if ($reftype eq 'HASH') {
494            return $_[0]->hash_to_json($_[1]);
495        }
496        elsif ($reftype eq 'ARRAY') {
497            return $_[0]->array_to_json($_[1]);
498        }
499        else {
500            return 'null';
501        }
502    }
503
504
505    sub encode_error {
506        my $error  = shift;
507        Carp::croak "$error";
508    }
509
510
511    sub _sort {
512        defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
513    }
514
515
516    sub _up_indent {
517        my $self  = shift;
518        my $space = ' ' x $indent_length;
519
520        my ($pre,$post) = ('','');
521
522        $post = "\n" . $space x $indent_count;
523
524        $indent_count++;
525
526        $pre = "\n" . $space x $indent_count;
527
528        return ($pre,$post);
529    }
530
531
532    sub _down_indent { $indent_count--; }
533
534
535    sub PP_encode_box {
536        {
537            depth        => $depth,
538            indent_count => $indent_count,
539        };
540    }
541
542} # Convert
543
544
545sub _encode_ascii {
546    join('',
547        map {
548            $_ <= 127 ?
549                chr($_) :
550            $_ <= 65535 ?
551                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
552        } unpack('U*', $_[0])
553    );
554}
555
556
557sub _encode_latin1 {
558    join('',
559        map {
560            $_ <= 255 ?
561                chr($_) :
562            $_ <= 65535 ?
563                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
564        } unpack('U*', $_[0])
565    );
566}
567
568
569sub _encode_surrogates { # from perlunicode
570    my $uni = $_[0] - 0x10000;
571    return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
572}
573
574
575sub _is_bignum {
576    $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
577}
578
579
580
581#
582# JSON => Perl
583#
584
585my $max_intsize;
586
587BEGIN {
588    my $checkint = 1111;
589    for my $d (5..64) {
590        $checkint .= 1;
591        my $int   = eval qq| $checkint |;
592        if ($int =~ /[eE]/) {
593            $max_intsize = $d - 1;
594            last;
595        }
596    }
597}
598
599{ # PARSE
600
601    my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
602        b    => "\x8",
603        t    => "\x9",
604        n    => "\xA",
605        f    => "\xC",
606        r    => "\xD",
607        '\\' => '\\',
608        '"'  => '"',
609        '/'  => '/',
610    );
611
612    my $text; # json data
613    my $at;   # offset
614    my $ch;   # 1chracter
615    my $len;  # text length (changed according to UTF8 or NON UTF8)
616    # INTERNAL
617    my $depth;          # nest counter
618    my $encoding;       # json text encoding
619    my $is_valid_utf8;  # temp variable
620    my $utf8_len;       # utf8 byte length
621    # FLAGS
622    my $utf8;           # must be utf8
623    my $max_depth;      # max nest nubmer of objects and arrays
624    my $max_size;
625    my $relaxed;
626    my $cb_object;
627    my $cb_sk_object;
628
629    my $F_HOOK;
630
631    my $allow_bigint;   # using Math::BigInt
632    my $singlequote;    # loosely quoting
633    my $loose;          #
634    my $allow_barekey;  # bareKey
635
636    # $opt flag
637    # 0x00000001 .... decode_prefix
638    # 0x10000000 .... incr_parse
639
640    sub PP_decode_json {
641        my ($self, $opt); # $opt is an effective flag during this decode_json.
642
643        ($self, $text, $opt) = @_;
644
645        ($at, $ch, $depth) = (0, '', 0);
646
647        if ( !defined $text or ref $text ) {
648            decode_error("malformed JSON string, neither array, object, number, string or atom");
649        }
650
651        my $idx = $self->{PROPS};
652
653        ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
654            = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
655
656        if ( $utf8 ) {
657            utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
658        }
659        else {
660            utf8::upgrade( $text );
661        }
662
663        $len = length $text;
664
665        ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
666             = @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};
667
668        if ($max_size > 1) {
669            use bytes;
670            my $bytes = length $text;
671            decode_error(
672                sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
673                    , $bytes, $max_size), 1
674            ) if ($bytes > $max_size);
675        }
676
677        # Currently no effect
678        # should use regexp
679        my @octets = unpack('C4', $text);
680        $encoding =   ( $octets[0] and  $octets[1]) ? 'UTF-8'
681                    : (!$octets[0] and  $octets[1]) ? 'UTF-16BE'
682                    : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
683                    : ( $octets[2]                ) ? 'UTF-16LE'
684                    : (!$octets[2]                ) ? 'UTF-32LE'
685                    : 'unknown';
686
687        white(); # remove head white space
688
689        my $valid_start = defined $ch; # Is there a first character for JSON structure?
690
691        my $result = value();
692
693        return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
694
695        decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
696
697        if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
698                decode_error(
699                'JSON text must be an object or array (but found number, string, true, false or null,'
700                       . ' use allow_nonref to allow this)', 1);
701        }
702
703        Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
704
705        my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
706
707        white(); # remove tail white space
708
709        if ( $ch ) {
710            return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
711            decode_error("garbage after JSON object");
712        }
713
714        ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
715    }
716
717
718    sub next_chr {
719        return $ch = undef if($at >= $len);
720        $ch = substr($text, $at++, 1);
721    }
722
723
724    sub value {
725        white();
726        return          if(!defined $ch);
727        return object() if($ch eq '{');
728        return array()  if($ch eq '[');
729        return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
730        return number() if($ch =~ /[0-9]/ or $ch eq '-');
731        return word();
732    }
733
734    sub string {
735        my ($i, $s, $t, $u);
736        my $utf16;
737        my $is_utf8;
738
739        ($is_valid_utf8, $utf8_len) = ('', 0);
740
741        $s = ''; # basically UTF8 flag on
742
743        if($ch eq '"' or ($singlequote and $ch eq "'")){
744            my $boundChar = $ch;
745
746            OUTER: while( defined(next_chr()) ){
747
748                if($ch eq $boundChar){
749                    next_chr();
750
751                    if ($utf16) {
752                        decode_error("missing low surrogate character in surrogate pair");
753                    }
754
755                    utf8::decode($s) if($is_utf8);
756
757                    return $s;
758                }
759                elsif($ch eq '\\'){
760                    next_chr();
761                    if(exists $escapes{$ch}){
762                        $s .= $escapes{$ch};
763                    }
764                    elsif($ch eq 'u'){ # UNICODE handling
765                        my $u = '';
766
767                        for(1..4){
768                            $ch = next_chr();
769                            last OUTER if($ch !~ /[0-9a-fA-F]/);
770                            $u .= $ch;
771                        }
772
773                        # U+D800 - U+DBFF
774                        if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
775                            $utf16 = $u;
776                        }
777                        # U+DC00 - U+DFFF
778                        elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
779                            unless (defined $utf16) {
780                                decode_error("missing high surrogate character in surrogate pair");
781                            }
782                            $is_utf8 = 1;
783                            $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
784                            $utf16 = undef;
785                        }
786                        else {
787                            if (defined $utf16) {
788                                decode_error("surrogate pair expected");
789                            }
790
791                            if ( ( my $hex = hex( $u ) ) > 127 ) {
792                                $is_utf8 = 1;
793                                $s .= JSON_PP_decode_unicode($u) || next;
794                            }
795                            else {
796                                $s .= chr $hex;
797                            }
798                        }
799
800                    }
801                    else{
802                        unless ($loose) {
803                            $at -= 2;
804                            decode_error('illegal backslash escape sequence in string');
805                        }
806                        $s .= $ch;
807                    }
808                }
809                else{
810
811                    if ( ord $ch  > 127 ) {
812                        if ( $utf8 ) {
813                            unless( $ch = is_valid_utf8($ch) ) {
814                                $at -= 1;
815                                decode_error("malformed UTF-8 character in JSON string");
816                            }
817                            else {
818                                $at += $utf8_len - 1;
819                            }
820                        }
821                        else {
822                            utf8::encode( $ch );
823                        }
824
825                        $is_utf8 = 1;
826                    }
827
828                    if (!$loose) {
829                        if ($ch =~ /[\x00-\x1f\x22\x5c]/)  { # '/' ok
830                            $at--;
831                            decode_error('invalid character encountered while parsing JSON string');
832                        }
833                    }
834
835                    $s .= $ch;
836                }
837            }
838        }
839
840        decode_error("unexpected end of string while parsing JSON string");
841    }
842
843
844    sub white {
845        while( defined $ch  ){
846            if($ch le ' '){
847                next_chr();
848            }
849            elsif($ch eq '/'){
850                next_chr();
851                if(defined $ch and $ch eq '/'){
852                    1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
853                }
854                elsif(defined $ch and $ch eq '*'){
855                    next_chr();
856                    while(1){
857                        if(defined $ch){
858                            if($ch eq '*'){
859                                if(defined(next_chr()) and $ch eq '/'){
860                                    next_chr();
861                                    last;
862                                }
863                            }
864                            else{
865                                next_chr();
866                            }
867                        }
868                        else{
869                            decode_error("Unterminated comment");
870                        }
871                    }
872                    next;
873                }
874                else{
875                    $at--;
876                    decode_error("malformed JSON string, neither array, object, number, string or atom");
877                }
878            }
879            else{
880                if ($relaxed and $ch eq '#') { # correctly?
881                    pos($text) = $at;
882                    $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
883                    $at = pos($text);
884                    next_chr;
885                    next;
886                }
887
888                last;
889            }
890        }
891    }
892
893
894    sub array {
895        my $a  = [];
896
897        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
898                                                    if (++$depth > $max_depth);
899
900        next_chr();
901        white();
902
903        if(defined $ch and $ch eq ']'){
904            --$depth;
905            next_chr();
906            return $a;
907        }
908        else {
909            while(defined($ch)){
910                push @$a, value();
911
912                white();
913
914                if (!defined $ch) {
915                    last;
916                }
917
918                if($ch eq ']'){
919                    --$depth;
920                    next_chr();
921                    return $a;
922                }
923
924                if($ch ne ','){
925                    last;
926                }
927
928                next_chr();
929                white();
930
931                if ($relaxed and $ch eq ']') {
932                    --$depth;
933                    next_chr();
934                    return $a;
935                }
936
937            }
938        }
939
940        decode_error(", or ] expected while parsing array");
941    }
942
943
944    sub object {
945        my $o = {};
946        my $k;
947
948        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
949                                                if (++$depth > $max_depth);
950        next_chr();
951        white();
952
953        if(defined $ch and $ch eq '}'){
954            --$depth;
955            next_chr();
956            if ($F_HOOK) {
957                return _json_object_hook($o);
958            }
959            return $o;
960        }
961        else {
962            while (defined $ch) {
963                $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
964                white();
965
966                if(!defined $ch or $ch ne ':'){
967                    $at--;
968                    decode_error("':' expected");
969                }
970
971                next_chr();
972                $o->{$k} = value();
973                white();
974
975                last if (!defined $ch);
976
977                if($ch eq '}'){
978                    --$depth;
979                    next_chr();
980                    if ($F_HOOK) {
981                        return _json_object_hook($o);
982                    }
983                    return $o;
984                }
985
986                if($ch ne ','){
987                    last;
988                }
989
990                next_chr();
991                white();
992
993                if ($relaxed and $ch eq '}') {
994                    --$depth;
995                    next_chr();
996                    if ($F_HOOK) {
997                        return _json_object_hook($o);
998                    }
999                    return $o;
1000                }
1001
1002            }
1003
1004        }
1005
1006        $at--;
1007        decode_error(", or } expected while parsing object/hash");
1008    }
1009
1010
1011    sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
1012        my $key;
1013        while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
1014            $key .= $ch;
1015            next_chr();
1016        }
1017        return $key;
1018    }
1019
1020
1021    sub word {
1022        my $word =  substr($text,$at-1,4);
1023
1024        if($word eq 'true'){
1025            $at += 3;
1026            next_chr;
1027            return $JSON::PP::true;
1028        }
1029        elsif($word eq 'null'){
1030            $at += 3;
1031            next_chr;
1032            return undef;
1033        }
1034        elsif($word eq 'fals'){
1035            $at += 3;
1036            if(substr($text,$at,1) eq 'e'){
1037                $at++;
1038                next_chr;
1039                return $JSON::PP::false;
1040            }
1041        }
1042
1043        $at--; # for decode_error report
1044
1045        decode_error("'null' expected")  if ($word =~ /^n/);
1046        decode_error("'true' expected")  if ($word =~ /^t/);
1047        decode_error("'false' expected") if ($word =~ /^f/);
1048        decode_error("malformed JSON string, neither array, object, number, string or atom");
1049    }
1050
1051
1052    sub number {
1053        my $n    = '';
1054        my $v;
1055
1056        # According to RFC4627, hex or oct digts are invalid.
1057        if($ch eq '0'){
1058            my $peek = substr($text,$at,1);
1059            my $hex  = $peek =~ /[xX]/; # 0 or 1
1060
1061            if($hex){
1062                decode_error("malformed number (leading zero must not be followed by another digit)");
1063                ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
1064            }
1065            else{ # oct
1066                ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
1067                if (defined $n and length $n > 1) {
1068                    decode_error("malformed number (leading zero must not be followed by another digit)");
1069                }
1070            }
1071
1072            if(defined $n and length($n)){
1073                if (!$hex and length($n) == 1) {
1074                   decode_error("malformed number (leading zero must not be followed by another digit)");
1075                }
1076                $at += length($n) + $hex;
1077                next_chr;
1078                return $hex ? hex($n) : oct($n);
1079            }
1080        }
1081
1082        if($ch eq '-'){
1083            $n = '-';
1084            next_chr;
1085            if (!defined $ch or $ch !~ /\d/) {
1086                decode_error("malformed number (no digits after initial minus)");
1087            }
1088        }
1089
1090        while(defined $ch and $ch =~ /\d/){
1091            $n .= $ch;
1092            next_chr;
1093        }
1094
1095        if(defined $ch and $ch eq '.'){
1096            $n .= '.';
1097
1098            next_chr;
1099            if (!defined $ch or $ch !~ /\d/) {
1100                decode_error("malformed number (no digits after decimal point)");
1101            }
1102            else {
1103                $n .= $ch;
1104            }
1105
1106            while(defined(next_chr) and $ch =~ /\d/){
1107                $n .= $ch;
1108            }
1109        }
1110
1111        if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
1112            $n .= $ch;
1113            next_chr;
1114
1115            if(defined($ch) and ($ch eq '+' or $ch eq '-')){
1116                $n .= $ch;
1117                next_chr;
1118                if (!defined $ch or $ch =~ /\D/) {
1119                    decode_error("malformed number (no digits after exp sign)");
1120                }
1121                $n .= $ch;
1122            }
1123            elsif(defined($ch) and $ch =~ /\d/){
1124                $n .= $ch;
1125            }
1126            else {
1127                decode_error("malformed number (no digits after exp sign)");
1128            }
1129
1130            while(defined(next_chr) and $ch =~ /\d/){
1131                $n .= $ch;
1132            }
1133
1134        }
1135
1136        $v .= $n;
1137
1138        if ($v !~ /[.eE]/ and length $v > $max_intsize) {
1139            if ($allow_bigint) { # from Adam Sussman
1140                require Math::BigInt;
1141                return Math::BigInt->new($v);
1142            }
1143            else {
1144                return "$v";
1145            }
1146        }
1147        elsif ($allow_bigint) {
1148            require Math::BigFloat;
1149            return Math::BigFloat->new($v);
1150        }
1151
1152        return 0+$v;
1153    }
1154
1155
1156    sub is_valid_utf8 {
1157
1158        $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
1159                  : $_[0] =~ /[\xC2-\xDF]/  ? 2
1160                  : $_[0] =~ /[\xE0-\xEF]/  ? 3
1161                  : $_[0] =~ /[\xF0-\xF4]/  ? 4
1162                  : 0
1163                  ;
1164
1165        return unless $utf8_len;
1166
1167        my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
1168
1169        return ( $is_valid_utf8 =~ /^(?:
1170             [\x00-\x7F]
1171            |[\xC2-\xDF][\x80-\xBF]
1172            |[\xE0][\xA0-\xBF][\x80-\xBF]
1173            |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
1174            |[\xED][\x80-\x9F][\x80-\xBF]
1175            |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
1176            |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
1177            |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
1178            |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
1179        )$/x )  ? $is_valid_utf8 : '';
1180    }
1181
1182
1183    sub decode_error {
1184        my $error  = shift;
1185        my $no_rep = shift;
1186        my $str    = defined $text ? substr($text, $at) : '';
1187        my $mess   = '';
1188        my $type   = $] >= 5.008           ? 'U*'
1189                   : $] <  5.006           ? 'C*'
1190                   : utf8::is_utf8( $str ) ? 'U*' # 5.6
1191                   : 'C*'
1192                   ;
1193
1194        for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
1195            $mess .=  $c == 0x07 ? '\a'
1196                    : $c == 0x09 ? '\t'
1197                    : $c == 0x0a ? '\n'
1198                    : $c == 0x0d ? '\r'
1199                    : $c == 0x0c ? '\f'
1200                    : $c <  0x20 ? sprintf('\x{%x}', $c)
1201                    : $c == 0x5c ? '\\\\'
1202                    : $c <  0x80 ? chr($c)
1203                    : sprintf('\x{%x}', $c)
1204                    ;
1205            if ( length $mess >= 20 ) {
1206                $mess .= '...';
1207                last;
1208            }
1209        }
1210
1211        unless ( length $mess ) {
1212            $mess = '(end of string)';
1213        }
1214
1215        Carp::croak (
1216            $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
1217        );
1218
1219    }
1220
1221
1222    sub _json_object_hook {
1223        my $o    = $_[0];
1224        my @ks = keys %{$o};
1225
1226        if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
1227            my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
1228            if (@val == 1) {
1229                return $val[0];
1230            }
1231        }
1232
1233        my @val = $cb_object->($o) if ($cb_object);
1234        if (@val == 0 or @val > 1) {
1235            return $o;
1236        }
1237        else {
1238            return $val[0];
1239        }
1240    }
1241
1242
1243    sub PP_decode_box {
1244        {
1245            text    => $text,
1246            at      => $at,
1247            ch      => $ch,
1248            len     => $len,
1249            depth   => $depth,
1250            encoding      => $encoding,
1251            is_valid_utf8 => $is_valid_utf8,
1252        };
1253    }
1254
1255} # PARSE
1256
1257
1258sub _decode_surrogates { # from perlunicode
1259    my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
1260    my $un  = pack('U*', $uni);
1261    utf8::encode( $un );
1262    return $un;
1263}
1264
1265
1266sub _decode_unicode {
1267    my $un = pack('U', hex shift);
1268    utf8::encode( $un );
1269    return $un;
1270}
1271
1272
1273
1274
1275
1276###############################
1277# Utilities
1278#
1279
1280BEGIN {
1281    eval 'require Scalar::Util';
1282    unless($@){
1283        *JSON::PP::blessed = \&Scalar::Util::blessed;
1284        *JSON::PP::reftype = \&Scalar::Util::reftype;
1285    }
1286    else{ # This code is from Sclar::Util.
1287        # warn $@;
1288        eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
1289        *JSON::PP::blessed = sub {
1290            local($@, $SIG{__DIE__}, $SIG{__WARN__});
1291            ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
1292        };
1293        my %tmap = qw(
1294            B::NULL   SCALAR
1295            B::HV     HASH
1296            B::AV     ARRAY
1297            B::CV     CODE
1298            B::IO     IO
1299            B::GV     GLOB
1300            B::REGEXP REGEXP
1301        );
1302        *JSON::PP::reftype = sub {
1303            my $r = shift;
1304
1305            return undef unless length(ref($r));
1306
1307            my $t = ref(B::svref_2object($r));
1308
1309            return
1310                exists $tmap{$t} ? $tmap{$t}
1311              : length(ref($$r)) ? 'REF'
1312              :                    'SCALAR';
1313        };
1314    }
1315}
1316
1317
1318# shamely copied and modified from JSON::XS code.
1319
1320$JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
1321$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1322
1323sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
1324
1325sub true  { $JSON::PP::true  }
1326sub false { $JSON::PP::false }
1327sub null  { undef; }
1328
1329###############################
1330
1331package JSON::PP::Boolean;
1332
1333
1334use overload (
1335   "0+"     => sub { ${$_[0]} },
1336   "++"     => sub { $_[0] = ${$_[0]} + 1 },
1337   "--"     => sub { $_[0] = ${$_[0]} - 1 },
1338   fallback => 1,
1339);
1340
1341
1342###############################
1343
1344package JSON::PP::IncrParser;
1345
1346use strict;
1347
1348use constant INCR_M_WS   => 0; # initial whitespace skipping
1349use constant INCR_M_STR  => 1; # inside string
1350use constant INCR_M_BS   => 2; # inside backslash
1351use constant INCR_M_JSON => 3; # outside anything, count nesting
1352use constant INCR_M_C0   => 4;
1353use constant INCR_M_C1   => 5;
1354
1355$JSON::PP::IncrParser::VERSION = '1.01';
1356
1357my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
1358
1359sub new {
1360    my ( $class ) = @_;
1361
1362    bless {
1363        incr_nest    => 0,
1364        incr_text    => undef,
1365        incr_parsing => 0,
1366        incr_p       => 0,
1367    }, $class;
1368}
1369
1370
1371sub incr_parse {
1372    my ( $self, $coder, $text ) = @_;
1373
1374    $self->{incr_text} = '' unless ( defined $self->{incr_text} );
1375
1376    if ( defined $text ) {
1377        if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
1378            utf8::upgrade( $self->{incr_text} ) ;
1379            utf8::decode( $self->{incr_text} ) ;
1380        }
1381        $self->{incr_text} .= $text;
1382    }
1383
1384
1385    my $max_size = $coder->get_max_size;
1386
1387    if ( defined wantarray ) {
1388
1389        $self->{incr_mode} = INCR_M_WS;
1390
1391        if ( wantarray ) {
1392            my @ret;
1393
1394            $self->{incr_parsing} = 1;
1395
1396            do {
1397                push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
1398
1399                unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
1400                    $self->{incr_mode} = INCR_M_WS;
1401                }
1402
1403            } until ( !$self->{incr_text} );
1404
1405            $self->{incr_parsing} = 0;
1406
1407            return @ret;
1408        }
1409        else { # in scalar context
1410            $self->{incr_parsing} = 1;
1411            my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
1412            $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
1413            return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
1414        }
1415
1416    }
1417
1418}
1419
1420
1421sub _incr_parse {
1422    my ( $self, $coder, $text, $skip ) = @_;
1423    my $p = $self->{incr_p};
1424    my $restore = $p;
1425
1426    my @obj;
1427    my $len = length $text;
1428
1429    if ( $self->{incr_mode} == INCR_M_WS ) {
1430        while ( $len > $p ) {
1431            my $s = substr( $text, $p, 1 );
1432            $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
1433            $self->{incr_mode} = INCR_M_JSON;
1434            last;
1435       }
1436    }
1437
1438    while ( $len > $p ) {
1439        my $s = substr( $text, $p++, 1 );
1440
1441        if ( $s eq '"' ) {
1442            if ( $self->{incr_mode} != INCR_M_STR  ) {
1443                $self->{incr_mode} = INCR_M_STR;
1444            }
1445            else {
1446                $self->{incr_mode} = INCR_M_JSON;
1447                unless ( $self->{incr_nest} ) {
1448                    last;
1449                }
1450            }
1451        }
1452
1453        if ( $self->{incr_mode} == INCR_M_JSON ) {
1454
1455            if ( $s eq '[' or $s eq '{' ) {
1456                if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
1457                    Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
1458                }
1459            }
1460            elsif ( $s eq ']' or $s eq '}' ) {
1461                last if ( --$self->{incr_nest} <= 0 );
1462            }
1463            elsif ( $s eq '#' ) {
1464                while ( $len > $p ) {
1465                    last if substr( $text, $p++, 1 ) eq "\n";
1466                }
1467            }
1468
1469        }
1470
1471    }
1472
1473    $self->{incr_p} = $p;
1474
1475    return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
1476
1477    return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
1478
1479    local $Carp::CarpLevel = 2;
1480
1481    $self->{incr_p} = $restore;
1482    $self->{incr_c} = $p;
1483
1484    my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
1485
1486    $self->{incr_text} = substr( $self->{incr_text}, $p );
1487    $self->{incr_p} = 0;
1488
1489    # To avoid syntax errors in newer versions of perl,
1490    # putting the return in brackets as explained at
1491    # https://rt.cpan.org/Public/Bug/Display.html?id=87302
1492    # "returns binds stronger than or, so the expressions after or are ignored.
1493    # See https://rt.perl.org/rt3/Public/Bug/Display.html?id=59802"
1494    return ($obj or '');
1495}
1496
1497
1498sub incr_text {
1499    if ( $_[0]->{incr_parsing} ) {
1500        Carp::croak("incr_text can not be called when the incremental parser already started parsing");
1501    }
1502    $_[0]->{incr_text};
1503}
1504
1505
1506sub incr_skip {
1507    my $self  = shift;
1508    $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
1509    $self->{incr_p} = 0;
1510}
1511
1512
1513sub incr_reset {
1514    my $self = shift;
1515    $self->{incr_text}    = undef;
1516    $self->{incr_p}       = 0;
1517    $self->{incr_mode}    = 0;
1518    $self->{incr_nest}    = 0;
1519    $self->{incr_parsing} = 0;
1520}
1521
1522###############################
1523
1524
15251;
1526__END__
1527=pod
1528
1529=head1 NAME
1530
1531JSON::PP - JSON::XS compatible pure-Perl module.
1532
1533=head1 SYNOPSIS
1534
1535 use JSON::PP;
1536
1537 # exported functions, they croak on error
1538 # and expect/generate UTF-8
1539
1540 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
1541 $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
1542
1543 # OO-interface
1544
1545 $coder = JSON::PP->new->ascii->pretty->allow_nonref;
1546 $pretty_printed_unencoded = $coder->encode ($perl_scalar);
1547 $perl_scalar = $coder->decode ($unicode_json_text);
1548
1549 # Note that JSON version 2.0 and above will automatically use
1550 # JSON::XS or JSON::PP, so you should be able to just:
1551 
1552 use JSON;
1553
1554=head1 DESCRIPTION
1555
1556This module is L<JSON::XS> compatible pure Perl module.
1557(Perl 5.8 or later is recommended)
1558
1559JSON::XS is the fastest and most proper JSON module on CPAN.
1560It is written by Marc Lehmann in C, so must be compiled and
1561installed in the used environment.
1562
1563JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
1564
1565
1566=head2 FEATURES
1567
1568=over
1569
1570=item * correct unicode handling
1571
1572This module knows how to handle Unicode (depending on Perl version).
1573
1574See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
1575
1576
1577=item * round-trip integrity
1578
1579When you serialise a perl data structure using only data types supported
1580by JSON and Perl, the deserialised data structure is identical on the Perl
1581level. (e.g. the string "2.0" doesn't suddenly become "2" just because
1582it looks like a number). There I<are> minor exceptions to this, read the
1583MAPPING section below to learn about those.
1584
1585
1586=item * strict checking of JSON correctness
1587
1588There is no guessing, no generating of illegal JSON texts by default,
1589and only JSON is accepted as input by default (the latter is a security feature).
1590But when some options are set, loose chcking features are available.
1591
1592=back
1593
1594=head1 FUNCTIONS
1595
1596Basically, check to L<JSON> or L<JSON::XS>.
1597
1598=head2 encode_json
1599
1600    $json_text = encode_json $perl_scalar
1601
1602=head2 decode_json
1603
1604    $perl_scalar = decode_json $json_text
1605
1606=head2 JSON::PP::true
1607
1608Returns JSON true value which is blessed object.
1609It C<isa> JSON::PP::Boolean object.
1610
1611=head2 JSON::PP::false
1612
1613Returns JSON false value which is blessed object.
1614It C<isa> JSON::PP::Boolean object.
1615
1616=head2 JSON::PP::null
1617
1618Returns C<undef>.
1619
1620=head1 METHODS
1621
1622Basically, check to L<JSON> or L<JSON::XS>.
1623
1624=head2 new
1625
1626    $json = new JSON::PP
1627
1628Rturns a new JSON::PP object that can be used to de/encode JSON
1629strings.
1630
1631=head2 ascii
1632
1633    $json = $json->ascii([$enable])
1634   
1635    $enabled = $json->get_ascii
1636
1637If $enable is true (or missing), then the encode method will not generate characters outside
1638the code range 0..127. Any Unicode characters outside that range will be escaped using either
1639a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
1640(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
1641
1642In Perl 5.005, there is no character having high value (more than 255).
1643See to L<UNICODE HANDLING ON PERLS>.
1644
1645If $enable is false, then the encode method will not escape Unicode characters unless
1646required by the JSON syntax or other flags. This results in a faster and more compact format.
1647
1648  JSON::PP->new->ascii(1)->encode([chr 0x10401])
1649  => ["\ud801\udc01"]
1650
1651=head2 latin1
1652
1653    $json = $json->latin1([$enable])
1654   
1655    $enabled = $json->get_latin1
1656
1657If $enable is true (or missing), then the encode method will encode the resulting JSON
1658text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
1659
1660If $enable is false, then the encode method will not escape Unicode characters
1661unless required by the JSON syntax or other flags.
1662
1663  JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
1664  => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
1665
1666See to L<UNICODE HANDLING ON PERLS>.
1667
1668=head2 utf8
1669
1670    $json = $json->utf8([$enable])
1671   
1672    $enabled = $json->get_utf8
1673
1674If $enable is true (or missing), then the encode method will encode the JSON result
1675into UTF-8, as required by many protocols, while the decode method expects to be handled
1676an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
1677characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
1678
1679(In Perl 5.005, any character outside the range 0..255 does not exist.
1680See to L<UNICODE HANDLING ON PERLS>.)
1681
1682In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
1683encoding families, as described in RFC4627.
1684
1685If $enable is false, then the encode method will return the JSON string as a (non-encoded)
1686Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
1687(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
1688
1689Example, output UTF-16BE-encoded JSON:
1690
1691  use Encode;
1692  $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
1693
1694Example, decode UTF-32LE-encoded JSON:
1695
1696  use Encode;
1697  $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
1698
1699
1700=head2 pretty
1701
1702    $json = $json->pretty([$enable])
1703
1704This enables (or disables) all of the C<indent>, C<space_before> and
1705C<space_after> flags in one call to generate the most readable
1706(or most compact) form possible.
1707
1708=head2 indent
1709
1710    $json = $json->indent([$enable])
1711   
1712    $enabled = $json->get_indent
1713
1714The default indent space length is three.
1715You can use C<indent_length> to change the length.
1716
1717=head2 space_before
1718
1719    $json = $json->space_before([$enable])
1720   
1721    $enabled = $json->get_space_before
1722
1723=head2 space_after
1724
1725    $json = $json->space_after([$enable])
1726   
1727    $enabled = $json->get_space_after
1728
1729=head2 relaxed
1730
1731    $json = $json->relaxed([$enable])
1732   
1733    $enabled = $json->get_relaxed
1734
1735=head2 canonical
1736
1737    $json = $json->canonical([$enable])
1738   
1739    $enabled = $json->get_canonical
1740
1741If you want your own sorting routine, you can give a code referece
1742or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
1743
1744=head2 allow_nonref
1745
1746    $json = $json->allow_nonref([$enable])
1747   
1748    $enabled = $json->get_allow_nonref
1749
1750=head2 allow_unknown
1751
1752    $json = $json->allow_unknown ([$enable])
1753   
1754    $enabled = $json->get_allow_unknown
1755
1756=head2 allow_blessed
1757
1758    $json = $json->allow_blessed([$enable])
1759   
1760    $enabled = $json->get_allow_blessed
1761
1762=head2 convert_blessed
1763
1764    $json = $json->convert_blessed([$enable])
1765   
1766    $enabled = $json->get_convert_blessed
1767
1768=head2 filter_json_object
1769
1770    $json = $json->filter_json_object([$coderef])
1771
1772=head2 filter_json_single_key_object
1773
1774    $json = $json->filter_json_single_key_object($key [=> $coderef])
1775
1776=head2 shrink
1777
1778    $json = $json->shrink([$enable])
1779   
1780    $enabled = $json->get_shrink
1781
1782In JSON::XS, this flag resizes strings generated by either
1783C<encode> or C<decode> to their minimum size possible.
1784It will also try to downgrade any strings to octet-form if possible.
1785
1786In JSON::PP, it is noop about resizing strings but tries
1787C<utf8::downgrade> to the returned string by C<encode>.
1788See to L<utf8>.
1789
1790See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
1791
1792=head2 max_depth
1793
1794    $json = $json->max_depth([$maximum_nesting_depth])
1795   
1796    $max_depth = $json->get_max_depth
1797
1798Sets the maximum nesting level (default C<512>) accepted while encoding
1799or decoding. If a higher nesting level is detected in JSON text or a Perl
1800data structure, then the encoder and decoder will stop and croak at that
1801point.
1802
1803Nesting level is defined by number of hash- or arrayrefs that the encoder
1804needs to traverse to reach a given point or the number of C<{> or C<[>
1805characters without their matching closing parenthesis crossed to reach a
1806given character in a string.
1807
1808If no argument is given, the highest possible setting will be used, which
1809is rarely useful.
1810
1811See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
1812
1813When a large value (100 or more) was set and it de/encodes a deep nested object/text,
1814it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
1815
1816=head2 max_size
1817
1818    $json = $json->max_size([$maximum_string_size])
1819   
1820    $max_size = $json->get_max_size
1821
1822Set the maximum length a JSON text may have (in bytes) where decoding is
1823being attempted. The default is C<0>, meaning no limit. When C<decode>
1824is called on a string that is longer then this many bytes, it will not
1825attempt to decode the string but throw an exception. This setting has no
1826effect on C<encode> (yet).
1827
1828If no argument is given, the limit check will be deactivated (same as when
1829C<0> is specified).
1830
1831See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
1832
1833=head2 encode
1834
1835    $json_text = $json->encode($perl_scalar)
1836
1837=head2 decode
1838
1839    $perl_scalar = $json->decode($json_text)
1840
1841=head2 decode_prefix
1842
1843    ($perl_scalar, $characters) = $json->decode_prefix($json_text)
1844
1845
1846=head1 INCREMENTAL PARSING
1847
1848Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
1849
1850In some cases, there is the need for incremental parsing of JSON texts.
1851This module does allow you to parse a JSON stream incrementally.
1852It does so by accumulating text until it has a full JSON object, which
1853it then can decode. This process is similar to using C<decode_prefix>
1854to see if a full JSON object is available, but is much more efficient
1855(and can be implemented with a minimum of method calls).
1856
1857This module will only attempt to parse the JSON text once it is sure it
1858has enough text to get a decisive result, using a very simple but
1859truly incremental parser. This means that it sometimes won't stop as
1860early as the full parser, for example, it doesn't detect parenthese
1861mismatches. The only thing it guarantees is that it starts decoding as
1862soon as a syntactically valid JSON text has been seen. This means you need
1863to set resource limits (e.g. C<max_size>) to ensure the parser will stop
1864parsing in the presence if syntax errors.
1865
1866The following methods implement this incremental parser.
1867
1868=head2 incr_parse
1869
1870    $json->incr_parse( [$string] ) # void context
1871   
1872    $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
1873   
1874    @obj_or_empty = $json->incr_parse( [$string] ) # list context
1875
1876This is the central parsing function. It can both append new text and
1877extract objects from the stream accumulated so far (both of these
1878functions are optional).
1879
1880If C<$string> is given, then this string is appended to the already
1881existing JSON fragment stored in the C<$json> object.
1882
1883After that, if the function is called in void context, it will simply
1884return without doing anything further. This can be used to add more text
1885in as many chunks as you want.
1886
1887If the method is called in scalar context, then it will try to extract
1888exactly I<one> JSON object. If that is successful, it will return this
1889object, otherwise it will return C<undef>. If there is a parse error,
1890this method will croak just as C<decode> would do (one can then use
1891C<incr_skip> to skip the errornous part). This is the most common way of
1892using the method.
1893
1894And finally, in list context, it will try to extract as many objects
1895from the stream as it can find and return them, or the empty list
1896otherwise. For this to work, there must be no separators between the JSON
1897objects or arrays, instead they must be concatenated back-to-back. If
1898an error occurs, an exception will be raised as in the scalar context
1899case. Note that in this case, any previously-parsed JSON texts will be
1900lost.
1901
1902Example: Parse some JSON arrays/objects in a given string and return them.
1903
1904    my @objs = JSON->new->incr_parse ("[5][7][1,2]");
1905
1906=head2 incr_text
1907
1908    $lvalue_string = $json->incr_text
1909
1910This method returns the currently stored JSON fragment as an lvalue, that
1911is, you can manipulate it. This I<only> works when a preceding call to
1912C<incr_parse> in I<scalar context> successfully returned an object. Under
1913all other circumstances you must not call this function (I mean it.
1914although in simple tests it might actually work, it I<will> fail under
1915real world conditions). As a special exception, you can also call this
1916method before having parsed anything.
1917
1918This function is useful in two cases: a) finding the trailing text after a
1919JSON object or b) parsing multiple JSON objects separated by non-JSON text
1920(such as commas).
1921
1922    $json->incr_text =~ s/\s*,\s*//;
1923
1924In Perl 5.005, C<lvalue> attribute is not available.
1925You must write codes like the below:
1926
1927    $string = $json->incr_text;
1928    $string =~ s/\s*,\s*//;
1929    $json->incr_text( $string );
1930
1931=head2 incr_skip
1932
1933    $json->incr_skip
1934
1935This will reset the state of the incremental parser and will remove the
1936parsed text from the input buffer. This is useful after C<incr_parse>
1937died, in which case the input buffer and incremental parser state is left
1938unchanged, to skip the text parsed so far and to reset the parse state.
1939
1940=head2 incr_reset
1941
1942    $json->incr_reset
1943
1944This completely resets the incremental parser, that is, after this call,
1945it will be as if the parser had never parsed anything.
1946
1947This is useful if you want ot repeatedly parse JSON objects and want to
1948ignore any trailing data, which means you have to reset the parser after
1949each successful decode.
1950
1951See to L<JSON::XS/INCREMENTAL PARSING> for examples.
1952
1953
1954=head1 JSON::PP OWN METHODS
1955
1956=head2 allow_singlequote
1957
1958    $json = $json->allow_singlequote([$enable])
1959
1960If C<$enable> is true (or missing), then C<decode> will accept
1961JSON strings quoted by single quotations that are invalid JSON
1962format.
1963
1964    $json->allow_singlequote->decode({"foo":'bar'});
1965    $json->allow_singlequote->decode({'foo':"bar"});
1966    $json->allow_singlequote->decode({'foo':'bar'});
1967
1968As same as the C<relaxed> option, this option may be used to parse
1969application-specific files written by humans.
1970
1971
1972=head2 allow_barekey
1973
1974    $json = $json->allow_barekey([$enable])
1975
1976If C<$enable> is true (or missing), then C<decode> will accept
1977bare keys of JSON object that are invalid JSON format.
1978
1979As same as the C<relaxed> option, this option may be used to parse
1980application-specific files written by humans.
1981
1982    $json->allow_barekey->decode('{foo:"bar"}');
1983
1984=head2 allow_bignum
1985
1986    $json = $json->allow_bignum([$enable])
1987
1988If C<$enable> is true (or missing), then C<decode> will convert
1989the big integer Perl cannot handle as integer into a L<Math::BigInt>
1990object and convert a floating number (any) into a L<Math::BigFloat>.
1991
1992On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
1993objects into JSON numbers with C<allow_blessed> enable.
1994
1995   $json->allow_nonref->allow_blessed->allow_bignum;
1996   $bigfloat = $json->decode('2.000000000000000000000000001');
1997   print $json->encode($bigfloat);
1998   # => 2.000000000000000000000000001
1999
2000See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
2001
2002=head2 loose
2003
2004    $json = $json->loose([$enable])
2005
2006The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
2007and the module doesn't allow to C<decode> to these (except for \x2f).
2008If C<$enable> is true (or missing), then C<decode>  will accept these
2009unescaped strings.
2010
2011    $json->loose->decode(qq|["abc
2012                                   def"]|);
2013
2014See L<JSON::XS/SSECURITY CONSIDERATIONS>.
2015
2016=head2 escape_slash
2017
2018    $json = $json->escape_slash([$enable])
2019
2020According to JSON Grammar, I<slash> (U+002F) is escaped. But default
2021JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
2022
2023If C<$enable> is true (or missing), then C<encode> will escape slashes.
2024
2025=head2 (OBSOLETED)as_nonblessed
2026
2027    $json = $json->as_nonblessed
2028
2029(OBSOLETED) If C<$enable> is true (or missing), then C<encode> will convert
2030a blessed hash reference or a blessed array reference (contains
2031other blessed references) into JSON members and arrays.
2032
2033This feature is effective only when C<allow_blessed> is enable.
2034
2035=head2 indent_length
2036
2037    $json = $json->indent_length($length)
2038
2039JSON::XS indent space length is 3 and cannot be changed.
2040JSON::PP set the indent space length with the given $length.
2041The default is 3. The acceptable range is 0 to 15.
2042
2043=head2 sort_by
2044
2045    $json = $json->sort_by($function_name)
2046    $json = $json->sort_by($subroutine_ref)
2047
2048If $function_name or $subroutine_ref are set, its sort routine are used
2049in encoding JSON objects.
2050
2051   $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
2052   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2053
2054   $js = $pc->sort_by('own_sort')->encode($obj);
2055   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2056
2057   sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
2058
2059As the sorting routine runs in the JSON::PP scope, the given
2060subroutine name and the special variables C<$a>, C<$b> will begin
2061'JSON::PP::'.
2062
2063If $integer is set, then the effect is same as C<canonical> on.
2064
2065=head1 INTERNAL
2066
2067For developers.
2068
2069=over
2070
2071=item PP_encode_box
2072
2073Returns
2074
2075        {
2076            depth        => $depth,
2077            indent_count => $indent_count,
2078        }
2079
2080
2081=item PP_decode_box
2082
2083Returns
2084
2085        {
2086            text    => $text,
2087            at      => $at,
2088            ch      => $ch,
2089            len     => $len,
2090            depth   => $depth,
2091            encoding      => $encoding,
2092            is_valid_utf8 => $is_valid_utf8,
2093        };
2094
2095=back
2096
2097=head1 MAPPING
2098
2099See to L<JSON::XS/MAPPING>.
2100
2101
2102=head1 UNICODE HANDLING ON PERLS
2103
2104If you do not know about Unicode on Perl well,
2105please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
2106
2107=head2 Perl 5.8 and later
2108
2109Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
2110
2111    $json->allow_nonref->encode(chr hex 3042);
2112    $json->allow_nonref->encode(chr hex 12345);
2113
2114Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
2115
2116    $json->allow_nonref->decode('"\u3042"');
2117    $json->allow_nonref->decode('"\ud808\udf45"');
2118
2119Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
2120
2121Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
2122so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
2123
2124
2125=head2 Perl 5.6
2126
2127Perl can handle Unicode and the JSON::PP de/encode methods also work.
2128
2129=head2 Perl 5.005
2130
2131Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
2132That means the unicode handling is not available.
2133
2134In encoding,
2135
2136    $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
2137    $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
2138
2139Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
2140as C<$value % 256>, so the above codes are equivalent to :
2141
2142    $json->allow_nonref->encode(chr 66);
2143    $json->allow_nonref->encode(chr 69);
2144
2145In decoding,
2146
2147    $json->decode('"\u00e3\u0081\u0082"');
2148
2149The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
2150japanese character (C<HIRAGANA LETTER A>).
2151And if it is represented in Unicode code point, C<U+3042>.
2152
2153Next,
2154
2155    $json->decode('"\u3042"');
2156
2157We ordinary expect the returned value is a Unicode character C<U+3042>.
2158But here is 5.005 world. This is C<0xE3 0x81 0x82>.
2159
2160    $json->decode('"\ud808\udf45"');
2161
2162This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
2163
2164
2165=head1 TODO
2166
2167=over
2168
2169=item speed
2170
2171=item memory saving
2172
2173=back
2174
2175
2176=head1 SEE ALSO
2177
2178Most of the document are copied and modified from JSON::XS doc.
2179
2180L<JSON::XS>
2181
2182RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
2183
2184=head1 AUTHOR
2185
2186Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
2187
2188
2189=head1 COPYRIGHT AND LICENSE
2190
2191Copyright 2007-2010 by Makamaka Hannyaharamitu
2192
2193This library is free software; you can redistribute it and/or modify
2194it under the same terms as Perl itself.
2195
2196=cut
Note: See TracBrowser for help on using the browser.