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