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