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

Revision 24921, 58.4 KB (checked in by davidb, 8 years ago)

Some of our perl CGI scripts use JSON, while included in the ActivePerl? distribution, it does not appear to be a standard Perl module

  • 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    return $obj or '';
1490}
1491
1492
1493sub incr_text {
1494    if ( $_[0]->{incr_parsing} ) {
1495        Carp::croak("incr_text can not be called when the incremental parser already started parsing");
1496    }
1497    $_[0]->{incr_text};
1498}
1499
1500
1501sub incr_skip {
1502    my $self  = shift;
1503    $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
1504    $self->{incr_p} = 0;
1505}
1506
1507
1508sub incr_reset {
1509    my $self = shift;
1510    $self->{incr_text}    = undef;
1511    $self->{incr_p}       = 0;
1512    $self->{incr_mode}    = 0;
1513    $self->{incr_nest}    = 0;
1514    $self->{incr_parsing} = 0;
1515}
1516
1517###############################
1518
1519
15201;
1521__END__
1522=pod
1523
1524=head1 NAME
1525
1526JSON::PP - JSON::XS compatible pure-Perl module.
1527
1528=head1 SYNOPSIS
1529
1530 use JSON::PP;
1531
1532 # exported functions, they croak on error
1533 # and expect/generate UTF-8
1534
1535 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
1536 $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
1537
1538 # OO-interface
1539
1540 $coder = JSON::PP->new->ascii->pretty->allow_nonref;
1541 $pretty_printed_unencoded = $coder->encode ($perl_scalar);
1542 $perl_scalar = $coder->decode ($unicode_json_text);
1543
1544 # Note that JSON version 2.0 and above will automatically use
1545 # JSON::XS or JSON::PP, so you should be able to just:
1546 
1547 use JSON;
1548
1549=head1 DESCRIPTION
1550
1551This module is L<JSON::XS> compatible pure Perl module.
1552(Perl 5.8 or later is recommended)
1553
1554JSON::XS is the fastest and most proper JSON module on CPAN.
1555It is written by Marc Lehmann in C, so must be compiled and
1556installed in the used environment.
1557
1558JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
1559
1560
1561=head2 FEATURES
1562
1563=over
1564
1565=item * correct unicode handling
1566
1567This module knows how to handle Unicode (depending on Perl version).
1568
1569See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
1570
1571
1572=item * round-trip integrity
1573
1574When you serialise a perl data structure using only data types supported
1575by JSON and Perl, the deserialised data structure is identical on the Perl
1576level. (e.g. the string "2.0" doesn't suddenly become "2" just because
1577it looks like a number). There I<are> minor exceptions to this, read the
1578MAPPING section below to learn about those.
1579
1580
1581=item * strict checking of JSON correctness
1582
1583There is no guessing, no generating of illegal JSON texts by default,
1584and only JSON is accepted as input by default (the latter is a security feature).
1585But when some options are set, loose chcking features are available.
1586
1587=back
1588
1589=head1 FUNCTIONS
1590
1591Basically, check to L<JSON> or L<JSON::XS>.
1592
1593=head2 encode_json
1594
1595    $json_text = encode_json $perl_scalar
1596
1597=head2 decode_json
1598
1599    $perl_scalar = decode_json $json_text
1600
1601=head2 JSON::PP::true
1602
1603Returns JSON true value which is blessed object.
1604It C<isa> JSON::PP::Boolean object.
1605
1606=head2 JSON::PP::false
1607
1608Returns JSON false value which is blessed object.
1609It C<isa> JSON::PP::Boolean object.
1610
1611=head2 JSON::PP::null
1612
1613Returns C<undef>.
1614
1615=head1 METHODS
1616
1617Basically, check to L<JSON> or L<JSON::XS>.
1618
1619=head2 new
1620
1621    $json = new JSON::PP
1622
1623Rturns a new JSON::PP object that can be used to de/encode JSON
1624strings.
1625
1626=head2 ascii
1627
1628    $json = $json->ascii([$enable])
1629   
1630    $enabled = $json->get_ascii
1631
1632If $enable is true (or missing), then the encode method will not generate characters outside
1633the code range 0..127. Any Unicode characters outside that range will be escaped using either
1634a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
1635(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
1636
1637In Perl 5.005, there is no character having high value (more than 255).
1638See to L<UNICODE HANDLING ON PERLS>.
1639
1640If $enable is false, then the encode method will not escape Unicode characters unless
1641required by the JSON syntax or other flags. This results in a faster and more compact format.
1642
1643  JSON::PP->new->ascii(1)->encode([chr 0x10401])
1644  => ["\ud801\udc01"]
1645
1646=head2 latin1
1647
1648    $json = $json->latin1([$enable])
1649   
1650    $enabled = $json->get_latin1
1651
1652If $enable is true (or missing), then the encode method will encode the resulting JSON
1653text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
1654
1655If $enable is false, then the encode method will not escape Unicode characters
1656unless required by the JSON syntax or other flags.
1657
1658  JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
1659  => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
1660
1661See to L<UNICODE HANDLING ON PERLS>.
1662
1663=head2 utf8
1664
1665    $json = $json->utf8([$enable])
1666   
1667    $enabled = $json->get_utf8
1668
1669If $enable is true (or missing), then the encode method will encode the JSON result
1670into UTF-8, as required by many protocols, while the decode method expects to be handled
1671an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
1672characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
1673
1674(In Perl 5.005, any character outside the range 0..255 does not exist.
1675See to L<UNICODE HANDLING ON PERLS>.)
1676
1677In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
1678encoding families, as described in RFC4627.
1679
1680If $enable is false, then the encode method will return the JSON string as a (non-encoded)
1681Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
1682(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
1683
1684Example, output UTF-16BE-encoded JSON:
1685
1686  use Encode;
1687  $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
1688
1689Example, decode UTF-32LE-encoded JSON:
1690
1691  use Encode;
1692  $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
1693
1694
1695=head2 pretty
1696
1697    $json = $json->pretty([$enable])
1698
1699This enables (or disables) all of the C<indent>, C<space_before> and
1700C<space_after> flags in one call to generate the most readable
1701(or most compact) form possible.
1702
1703=head2 indent
1704
1705    $json = $json->indent([$enable])
1706   
1707    $enabled = $json->get_indent
1708
1709The default indent space length is three.
1710You can use C<indent_length> to change the length.
1711
1712=head2 space_before
1713
1714    $json = $json->space_before([$enable])
1715   
1716    $enabled = $json->get_space_before
1717
1718=head2 space_after
1719
1720    $json = $json->space_after([$enable])
1721   
1722    $enabled = $json->get_space_after
1723
1724=head2 relaxed
1725
1726    $json = $json->relaxed([$enable])
1727   
1728    $enabled = $json->get_relaxed
1729
1730=head2 canonical
1731
1732    $json = $json->canonical([$enable])
1733   
1734    $enabled = $json->get_canonical
1735
1736If you want your own sorting routine, you can give a code referece
1737or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
1738
1739=head2 allow_nonref
1740
1741    $json = $json->allow_nonref([$enable])
1742   
1743    $enabled = $json->get_allow_nonref
1744
1745=head2 allow_unknown
1746
1747    $json = $json->allow_unknown ([$enable])
1748   
1749    $enabled = $json->get_allow_unknown
1750
1751=head2 allow_blessed
1752
1753    $json = $json->allow_blessed([$enable])
1754   
1755    $enabled = $json->get_allow_blessed
1756
1757=head2 convert_blessed
1758
1759    $json = $json->convert_blessed([$enable])
1760   
1761    $enabled = $json->get_convert_blessed
1762
1763=head2 filter_json_object
1764
1765    $json = $json->filter_json_object([$coderef])
1766
1767=head2 filter_json_single_key_object
1768
1769    $json = $json->filter_json_single_key_object($key [=> $coderef])
1770
1771=head2 shrink
1772
1773    $json = $json->shrink([$enable])
1774   
1775    $enabled = $json->get_shrink
1776
1777In JSON::XS, this flag resizes strings generated by either
1778C<encode> or C<decode> to their minimum size possible.
1779It will also try to downgrade any strings to octet-form if possible.
1780
1781In JSON::PP, it is noop about resizing strings but tries
1782C<utf8::downgrade> to the returned string by C<encode>.
1783See to L<utf8>.
1784
1785See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
1786
1787=head2 max_depth
1788
1789    $json = $json->max_depth([$maximum_nesting_depth])
1790   
1791    $max_depth = $json->get_max_depth
1792
1793Sets the maximum nesting level (default C<512>) accepted while encoding
1794or decoding. If a higher nesting level is detected in JSON text or a Perl
1795data structure, then the encoder and decoder will stop and croak at that
1796point.
1797
1798Nesting level is defined by number of hash- or arrayrefs that the encoder
1799needs to traverse to reach a given point or the number of C<{> or C<[>
1800characters without their matching closing parenthesis crossed to reach a
1801given character in a string.
1802
1803If no argument is given, the highest possible setting will be used, which
1804is rarely useful.
1805
1806See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
1807
1808When a large value (100 or more) was set and it de/encodes a deep nested object/text,
1809it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
1810
1811=head2 max_size
1812
1813    $json = $json->max_size([$maximum_string_size])
1814   
1815    $max_size = $json->get_max_size
1816
1817Set the maximum length a JSON text may have (in bytes) where decoding is
1818being attempted. The default is C<0>, meaning no limit. When C<decode>
1819is called on a string that is longer then this many bytes, it will not
1820attempt to decode the string but throw an exception. This setting has no
1821effect on C<encode> (yet).
1822
1823If no argument is given, the limit check will be deactivated (same as when
1824C<0> is specified).
1825
1826See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
1827
1828=head2 encode
1829
1830    $json_text = $json->encode($perl_scalar)
1831
1832=head2 decode
1833
1834    $perl_scalar = $json->decode($json_text)
1835
1836=head2 decode_prefix
1837
1838    ($perl_scalar, $characters) = $json->decode_prefix($json_text)
1839
1840
1841=head1 INCREMENTAL PARSING
1842
1843Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
1844
1845In some cases, there is the need for incremental parsing of JSON texts.
1846This module does allow you to parse a JSON stream incrementally.
1847It does so by accumulating text until it has a full JSON object, which
1848it then can decode. This process is similar to using C<decode_prefix>
1849to see if a full JSON object is available, but is much more efficient
1850(and can be implemented with a minimum of method calls).
1851
1852This module will only attempt to parse the JSON text once it is sure it
1853has enough text to get a decisive result, using a very simple but
1854truly incremental parser. This means that it sometimes won't stop as
1855early as the full parser, for example, it doesn't detect parenthese
1856mismatches. The only thing it guarantees is that it starts decoding as
1857soon as a syntactically valid JSON text has been seen. This means you need
1858to set resource limits (e.g. C<max_size>) to ensure the parser will stop
1859parsing in the presence if syntax errors.
1860
1861The following methods implement this incremental parser.
1862
1863=head2 incr_parse
1864
1865    $json->incr_parse( [$string] ) # void context
1866   
1867    $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
1868   
1869    @obj_or_empty = $json->incr_parse( [$string] ) # list context
1870
1871This is the central parsing function. It can both append new text and
1872extract objects from the stream accumulated so far (both of these
1873functions are optional).
1874
1875If C<$string> is given, then this string is appended to the already
1876existing JSON fragment stored in the C<$json> object.
1877
1878After that, if the function is called in void context, it will simply
1879return without doing anything further. This can be used to add more text
1880in as many chunks as you want.
1881
1882If the method is called in scalar context, then it will try to extract
1883exactly I<one> JSON object. If that is successful, it will return this
1884object, otherwise it will return C<undef>. If there is a parse error,
1885this method will croak just as C<decode> would do (one can then use
1886C<incr_skip> to skip the errornous part). This is the most common way of
1887using the method.
1888
1889And finally, in list context, it will try to extract as many objects
1890from the stream as it can find and return them, or the empty list
1891otherwise. For this to work, there must be no separators between the JSON
1892objects or arrays, instead they must be concatenated back-to-back. If
1893an error occurs, an exception will be raised as in the scalar context
1894case. Note that in this case, any previously-parsed JSON texts will be
1895lost.
1896
1897Example: Parse some JSON arrays/objects in a given string and return them.
1898
1899    my @objs = JSON->new->incr_parse ("[5][7][1,2]");
1900
1901=head2 incr_text
1902
1903    $lvalue_string = $json->incr_text
1904
1905This method returns the currently stored JSON fragment as an lvalue, that
1906is, you can manipulate it. This I<only> works when a preceding call to
1907C<incr_parse> in I<scalar context> successfully returned an object. Under
1908all other circumstances you must not call this function (I mean it.
1909although in simple tests it might actually work, it I<will> fail under
1910real world conditions). As a special exception, you can also call this
1911method before having parsed anything.
1912
1913This function is useful in two cases: a) finding the trailing text after a
1914JSON object or b) parsing multiple JSON objects separated by non-JSON text
1915(such as commas).
1916
1917    $json->incr_text =~ s/\s*,\s*//;
1918
1919In Perl 5.005, C<lvalue> attribute is not available.
1920You must write codes like the below:
1921
1922    $string = $json->incr_text;
1923    $string =~ s/\s*,\s*//;
1924    $json->incr_text( $string );
1925
1926=head2 incr_skip
1927
1928    $json->incr_skip
1929
1930This will reset the state of the incremental parser and will remove the
1931parsed text from the input buffer. This is useful after C<incr_parse>
1932died, in which case the input buffer and incremental parser state is left
1933unchanged, to skip the text parsed so far and to reset the parse state.
1934
1935=head2 incr_reset
1936
1937    $json->incr_reset
1938
1939This completely resets the incremental parser, that is, after this call,
1940it will be as if the parser had never parsed anything.
1941
1942This is useful if you want ot repeatedly parse JSON objects and want to
1943ignore any trailing data, which means you have to reset the parser after
1944each successful decode.
1945
1946See to L<JSON::XS/INCREMENTAL PARSING> for examples.
1947
1948
1949=head1 JSON::PP OWN METHODS
1950
1951=head2 allow_singlequote
1952
1953    $json = $json->allow_singlequote([$enable])
1954
1955If C<$enable> is true (or missing), then C<decode> will accept
1956JSON strings quoted by single quotations that are invalid JSON
1957format.
1958
1959    $json->allow_singlequote->decode({"foo":'bar'});
1960    $json->allow_singlequote->decode({'foo':"bar"});
1961    $json->allow_singlequote->decode({'foo':'bar'});
1962
1963As same as the C<relaxed> option, this option may be used to parse
1964application-specific files written by humans.
1965
1966
1967=head2 allow_barekey
1968
1969    $json = $json->allow_barekey([$enable])
1970
1971If C<$enable> is true (or missing), then C<decode> will accept
1972bare keys of JSON object that are invalid JSON format.
1973
1974As same as the C<relaxed> option, this option may be used to parse
1975application-specific files written by humans.
1976
1977    $json->allow_barekey->decode('{foo:"bar"}');
1978
1979=head2 allow_bignum
1980
1981    $json = $json->allow_bignum([$enable])
1982
1983If C<$enable> is true (or missing), then C<decode> will convert
1984the big integer Perl cannot handle as integer into a L<Math::BigInt>
1985object and convert a floating number (any) into a L<Math::BigFloat>.
1986
1987On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
1988objects into JSON numbers with C<allow_blessed> enable.
1989
1990   $json->allow_nonref->allow_blessed->allow_bignum;
1991   $bigfloat = $json->decode('2.000000000000000000000000001');
1992   print $json->encode($bigfloat);
1993   # => 2.000000000000000000000000001
1994
1995See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
1996
1997=head2 loose
1998
1999    $json = $json->loose([$enable])
2000
2001The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
2002and the module doesn't allow to C<decode> to these (except for \x2f).
2003If C<$enable> is true (or missing), then C<decode>  will accept these
2004unescaped strings.
2005
2006    $json->loose->decode(qq|["abc
2007                                   def"]|);
2008
2009See L<JSON::XS/SSECURITY CONSIDERATIONS>.
2010
2011=head2 escape_slash
2012
2013    $json = $json->escape_slash([$enable])
2014
2015According to JSON Grammar, I<slash> (U+002F) is escaped. But default
2016JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
2017
2018If C<$enable> is true (or missing), then C<encode> will escape slashes.
2019
2020=head2 (OBSOLETED)as_nonblessed
2021
2022    $json = $json->as_nonblessed
2023
2024(OBSOLETED) If C<$enable> is true (or missing), then C<encode> will convert
2025a blessed hash reference or a blessed array reference (contains
2026other blessed references) into JSON members and arrays.
2027
2028This feature is effective only when C<allow_blessed> is enable.
2029
2030=head2 indent_length
2031
2032    $json = $json->indent_length($length)
2033
2034JSON::XS indent space length is 3 and cannot be changed.
2035JSON::PP set the indent space length with the given $length.
2036The default is 3. The acceptable range is 0 to 15.
2037
2038=head2 sort_by
2039
2040    $json = $json->sort_by($function_name)
2041    $json = $json->sort_by($subroutine_ref)
2042
2043If $function_name or $subroutine_ref are set, its sort routine are used
2044in encoding JSON objects.
2045
2046   $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
2047   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2048
2049   $js = $pc->sort_by('own_sort')->encode($obj);
2050   # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
2051
2052   sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
2053
2054As the sorting routine runs in the JSON::PP scope, the given
2055subroutine name and the special variables C<$a>, C<$b> will begin
2056'JSON::PP::'.
2057
2058If $integer is set, then the effect is same as C<canonical> on.
2059
2060=head1 INTERNAL
2061
2062For developers.
2063
2064=over
2065
2066=item PP_encode_box
2067
2068Returns
2069
2070        {
2071            depth        => $depth,
2072            indent_count => $indent_count,
2073        }
2074
2075
2076=item PP_decode_box
2077
2078Returns
2079
2080        {
2081            text    => $text,
2082            at      => $at,
2083            ch      => $ch,
2084            len     => $len,
2085            depth   => $depth,
2086            encoding      => $encoding,
2087            is_valid_utf8 => $is_valid_utf8,
2088        };
2089
2090=back
2091
2092=head1 MAPPING
2093
2094See to L<JSON::XS/MAPPING>.
2095
2096
2097=head1 UNICODE HANDLING ON PERLS
2098
2099If you do not know about Unicode on Perl well,
2100please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
2101
2102=head2 Perl 5.8 and later
2103
2104Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
2105
2106    $json->allow_nonref->encode(chr hex 3042);
2107    $json->allow_nonref->encode(chr hex 12345);
2108
2109Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
2110
2111    $json->allow_nonref->decode('"\u3042"');
2112    $json->allow_nonref->decode('"\ud808\udf45"');
2113
2114Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
2115
2116Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
2117so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
2118
2119
2120=head2 Perl 5.6
2121
2122Perl can handle Unicode and the JSON::PP de/encode methods also work.
2123
2124=head2 Perl 5.005
2125
2126Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
2127That means the unicode handling is not available.
2128
2129In encoding,
2130
2131    $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
2132    $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
2133
2134Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
2135as C<$value % 256>, so the above codes are equivalent to :
2136
2137    $json->allow_nonref->encode(chr 66);
2138    $json->allow_nonref->encode(chr 69);
2139
2140In decoding,
2141
2142    $json->decode('"\u00e3\u0081\u0082"');
2143
2144The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
2145japanese character (C<HIRAGANA LETTER A>).
2146And if it is represented in Unicode code point, C<U+3042>.
2147
2148Next,
2149
2150    $json->decode('"\u3042"');
2151
2152We ordinary expect the returned value is a Unicode character C<U+3042>.
2153But here is 5.005 world. This is C<0xE3 0x81 0x82>.
2154
2155    $json->decode('"\ud808\udf45"');
2156
2157This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
2158
2159
2160=head1 TODO
2161
2162=over
2163
2164=item speed
2165
2166=item memory saving
2167
2168=back
2169
2170
2171=head1 SEE ALSO
2172
2173Most of the document are copied and modified from JSON::XS doc.
2174
2175L<JSON::XS>
2176
2177RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
2178
2179=head1 AUTHOR
2180
2181Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
2182
2183
2184=head1 COPYRIGHT AND LICENSE
2185
2186Copyright 2007-2010 by Makamaka Hannyaharamitu
2187
2188This library is free software; you can redistribute it and/or modify
2189it under the same terms as Perl itself.
2190
2191=cut
Note: See TracBrowser for help on using the browser.