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