• source navigation  • diff markup  • identifier search  • freetext search  • 

Sources/uqmi/data/lib/JSON/backportPP.pm

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

This page was automatically generated by LXR 0.3.1.  •  OpenWrt