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