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