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