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

Last change on this file since 31781 was 31781, checked in by ak19, 4 years ago

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

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