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 = '0.97'; 15 16@JSON::PP::EXPORT = qw(from_json to_json jsonToObj objToJson); 17 18*jsonToObj = *from_json; # will be obsoleted. 19*objToJson = *to_json; # will be obsoleted. 20 21 22 23BEGIN { 24 my @properties = qw( 25 utf8 allow_nonref indent space_before space_after canonical max_depth shrink 26 self_encode singlequote allow_bigint disable_UTF8 strict 27 allow_barekey escape_slash literal_value 28 allow_blessed convert_blessed relaxed 29 ); 30 31 # Perl version check, ascii() is enable? 32 # Helper module may set @JSON::PP::_properties. 33 if ($] >= 5.008) { 34 require Encode; 35 push @properties, 'ascii', 'latin1'; 36 37 *utf8::is_utf8 = *Encode::is_utf8 if ($] == 5.008); 38 39 *JSON_encode_ascii = *_encode_ascii; 40 *JSON_encode_latin1 = *_encode_latin1; 41 *JSON_decode_unicode = *_decode_unicode; 42 } 43 else { 44 my $helper = $] >= 5.006 ? 'JSON::PP56' : 'JSON::PP5005'; 45 eval qq| require $helper |; 46 if ($@) { Carp::croak $@; } 47 push @properties, @JSON::PP::_properties; 48 } 49 50 for my $name (@properties) { 51 eval qq| 52 sub $name { 53 \$_[0]->{$name} = defined \$_[1] ? \$_[1] : 1; 54 \$_[0]; 55 } 56 |; 57 } 58 59} 60 61 62 63# Functions 64 65my %encode_allow_method 66 = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 allow_tied self_encode escape_slash 67 allow_blessed convert_blessed 68 /; 69my %decode_allow_method 70 = map {($_ => 1)} qw/utf8 allow_nonref disable_UTF8 strict singlequote allow_bigint 71 allow_barekey literal_value max_size relaxed/; 72 73 74sub to_json { # encode 75 my ($obj, $opt) = @_; 76 77 if ($opt) { 78 my $json = JSON::PP->new->utf8; 79 80 for my $method (keys %$opt) { 81 Carp::croak("non acceptble option") 82 unless (exists $encode_allow_method{$method}); 83 $json->$method($opt->{$method}); 84 } 85 86 return $json->encode($obj); 87 } 88 else { 89 return __PACKAGE__->new->utf8->encode($obj); 90 } 91 92} 93 94 95sub from_json { # decode 96 my ($obj, $opt) = @_; 97 98 if ($opt) { 99 my $json = JSON::PP->new->utf8; 100 101 for my $method (keys %$opt) { 102 Carp::croak("non acceptble option") 103 unless (exists $decode_allow_method{$method}); 104 $json->$method($opt->{$method}); 105 } 106 107 return $json->decode($obj); 108 } 109 else { 110 __PACKAGE__->new->utf8->decode(shift); 111 } 112} 113 114 115# Methods 116 117sub new { 118 my $class = shift; 119 my $self = { 120 max_depth => 512, 121 unmap => 1, 122 indent => 0, 123 fallback => sub { encode_error('Invalid value. JSON can only reference.') }, 124 }; 125 126 bless $self, $class; 127} 128 129 130sub encode { 131 return $_[0]->encode_json($_[1]); 132} 133 134 135sub decode { 136 return $_[0]->decode_json($_[1], 0x00000000); 137} 138 139 140sub decode_prefix { 141 return $_[0]->decode_json($_[1], 0x00000001); 142} 143 144 145# accessor 146 147sub property { 148 my ($self, $name, $value) = @_; 149 150 if (@_ == 1) { 151 Carp::croak('property() requires 1 or 2 arguments.'); 152 } 153 elsif (@_ == 2) { 154 $self->{$name}; 155 } 156 else { 157 $self->$name($value); 158 } 159} 160 161 162# pretty printing 163 164sub pretty { 165 my ($self, $v) = @_; 166 $self->{pretty} = defined $v ? $v : 1; 167 168 if ($v) { # JSON::PP's indent(3) ... JSON::XS indent(1) compati 169 $self->indent(3); 170 $self->space_before(1); 171 $self->space_after(1); 172 } 173 else { 174 $self->indent(0); 175 $self->space_before(0); 176 $self->space_after(0); 177 } 178 179 $self; 180} 181 182# etc 183 184sub filter_json_object { 185 $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; 186 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; 187 $_[0]; 188} 189 190sub filter_json_single_key_object { 191 if (@_ > 1) { 192 $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; 193 } 194 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; 195 $_[0]; 196} 197 198sub max_size { # as default is 0, written here. 199 $_[0]->{max_size} = defined $_[1] ? $_[1] : 0; 200 $_[0]; 201} 202 203############################### 204 205### 206### Perl => JSON 207### 208 209{ # Convert 210 211 my $depth; 212 my $max_depth; 213 my $keysort; 214 my $indent; 215 my $indent_count; 216 my $ascii; 217 my $utf8; 218 my $self_encode; 219 my $disable_UTF8; 220 my $escape_slash; 221 222 my $latin1; 223 my $allow_blessed; 224 my $convert_blessed; 225 226 227 sub encode_json { 228 my $self = shift; 229 my $obj = shift; 230 231 $indent_count = 0; 232 $depth = 0; 233 234 ($indent, $ascii, $utf8, $self_encode, $max_depth, $disable_UTF8, $escape_slash, $latin1, 235 $allow_blessed, $convert_blessed) 236 = @{$self}{qw/indent ascii utf8 self_encode max_depth disable_UTF8 escape_slash latin1 237 allow_blessed convert_blessed 238 /}; 239 240 $keysort = !$self->{canonical} ? undef 241 : ref($self->{canonical}) eq 'CODE' ? $self->{canonical} 242 : $self->{canonical} =~ /\D+/ ? $self->{canonical} 243 : sub { $a cmp $b }; 244 245 my $str = $self->toJson($obj); 246 247 if (!defined $str and $self->{allow_nonref}){ 248 $str = $self->valueToJson($obj); 249 } 250 251 encode_error("non ref") unless(defined $str); 252 253 return $str; 254 } 255 256 257 sub toJson { 258 my ($self, $obj) = @_; 259 my $type = ref($obj); 260 261 if($type eq 'HASH'){ 262 return $self->hashToJson($obj); 263 } 264 elsif($type eq 'ARRAY'){ 265 return $self->arrayToJson($obj); 266 } 267 elsif ($type) { # blessed object? 268 if (blessed($obj)) { 269 270 if ($convert_blessed) { 271 if ( $obj->can('TO_JSON') ) { 272 return $self->toJson( $obj->TO_JSON() ); 273 } 274 } 275 276 if ($self->{self_encode} and $obj->can('toJson')) { 277 return $self->selfToJson($obj); 278 } 279 elsif (!$obj->isa('JSON::PP::Boolean')) { # handling in valueToJson 280 281 encode_error("allow_blessed") unless ($allow_blessed); 282 283 return 'null' unless ($convert_blessed); 284 285 return 'null'; 286 } 287 } 288 else { 289 return $self->valueToJson($obj); 290 } 291 } 292 else{ 293 return; 294 } 295 } 296 297 298 sub hashToJson { 299 my ($self, $obj) = @_; 300 my ($k,$v); 301 my %res; 302 303 encode_error("data structure too deep (hit recursion limit)") 304 if (++$depth > $max_depth); 305 306 my ($pre, $post) = $indent ? $self->_upIndent() : ('', ''); 307 my $del = ($self->{space_before} ? ' ' : '') . ':' . ($self->{space_after} ? ' ' : ''); 308 309 for my $k (keys %$obj) { 310 my $v = $obj->{$k}; 311 $res{$k} = $self->toJson($v) || $self->valueToJson($v); 312 } 313 314 --$depth; 315 $self->_downIndent() if ($indent); 316 317 return '{' . $pre 318 . join(",$pre", map { utf8::decode($_) if ($] < 5.008); 319 _stringfy($self, $_) 320 . $del . $res{$_} } _sort($self, \%res)) 321 . $post 322 . '}'; 323 } 324 325 326 sub arrayToJson { 327 my ($self, $obj) = @_; 328 my @res; 329 330 encode_error("data structure too deep (hit recursion limit)") 331 if (++$depth > $max_depth); 332 333 my ($pre, $post) = $indent ? $self->_upIndent() : ('', ''); 334 335 for my $v (@$obj){ 336 push @res, $self->toJson($v) || $self->valueToJson($v); 337 } 338 339 --$depth; 340 $self->_downIndent() if ($indent); 341 342 return '[' . $pre . join(",$pre" ,@res) . $post . ']'; 343 } 344 345 346 sub valueToJson { 347 my ($self, $value) = @_; 348 349 return 'null' if(!defined $value); 350 351 my $b_obj = B::svref_2object(\$value); # for round trip problem 352 # SvTYPE is IV or NV? 353 354 return $value # as is 355 if ( ($b_obj->FLAGS & B::SVf_IOK or $b_obj->FLAGS & B::SVp_IOK 356 or $b_obj->FLAGS & B::SVf_NOK or $b_obj->FLAGS & B::SVp_NOK 357 ) and !($b_obj->FLAGS & B::SVf_POK ) 358 ); 359 360 my $type = ref($value); 361 362 if(!$type){ 363 return _stringfy($self, $value); 364 } 365 elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ 366 return $$value == 1 ? 'true' : 'false'; 367 } 368 elsif ($type) { 369 if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { 370 return $self->valueToJson("$value"); 371 } 372 373 if ($type eq 'SCALAR' and defined $$value) { 374 return $$value eq '1' ? 'true' 375 : $$value eq '0' ? 'false' : encode_error("cannot encode reference."); 376 } 377 378 if ($type eq 'CODE') { 379 encode_error("JSON can only reference."); 380 } 381 else { 382 encode_error("cannot encode reference."); 383 } 384 385 } 386 else { 387 return $self->{fallback}->($value) 388 if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); 389 return 'null'; 390 } 391 392 } 393 394 395 my %esc = ( 396 "\n" => '\n', 397 "\r" => '\r', 398 "\t" => '\t', 399 "\f" => '\f', 400 "\b" => '\b', 401 "\"" => '\"', 402 "\\" => '\\\\', 403 "\'" => '\\\'', 404 ); 405 406 407 sub _stringfy { 408 my ($self, $arg) = @_; 409 410 $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/eg; 411 $arg =~ s/\//\\\//g if ($escape_slash); 412 $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; 413 414 if ($ascii) { 415 $arg = JSON_encode_ascii($arg); 416 } 417 418 if ($latin1) { 419 $arg = JSON_encode_latin1($arg); 420 } 421 422 if ($utf8 or $disable_UTF8) { 423 utf8::encode($arg); 424 } 425 426 return '"' . $arg . '"'; 427 } 428 429 430 sub selfToJson { 431 my ($self, $obj) = @_; 432 return $obj->toJson($self); 433 } 434 435 436 sub encode_error { 437 my $error = shift; 438 Carp::croak "$error"; 439 } 440 441 442 sub _sort { 443 my ($self, $res) = @_; 444 defined $keysort ? (sort $keysort (keys %$res)) : keys %$res; 445 } 446 447 448 sub _upIndent { 449 my $self = shift; 450 my $space = ' ' x $indent; 451 452 my ($pre,$post) = ('',''); 453 454 $post = "\n" . $space x $indent_count; 455 456 $indent_count++; 457 458 $pre = "\n" . $space x $indent_count; 459 460 return ($pre,$post); 461 } 462 463 464 sub _downIndent { $_[0]->{indent_count}--; } 465 466} # Convert 467 468 469 470sub _encode_ascii { 471 join('', 472 map { 473 $_ <= 127 ? 474 chr($_) : 475 $_ <= 65535 ? 476 sprintf('\u%04x', $_) : 477 join("", map { '\u' . $_ } 478 unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); 479 } unpack('U*', $_[0]) 480 ); 481} 482 483 484sub _encode_latin1 { 485 join('', 486 map { 487 $_ <= 255 ? 488 chr($_) : 489 $_ <= 65535 ? 490 sprintf('\u%04x', $_) : 491 join("", map { '\u' . $_ } 492 unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); 493 } unpack('U*', $_[0]) 494 ); 495} 496 497 498 499# 500# JSON => Perl 501# 502 503# from Adam Sussman 504use Config; 505my $max_intsize = length(((1 << (8 * $Config{intsize} - 2))-1)*2 + 1) - 1; 506#my $max_intsize = length(2 ** ($Config{intsize} * 8)) - 1; 507 508 509{ # PARSE 510 511 my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> 512 b => "\x8", 513 t => "\x9", 514 n => "\xA", 515 f => "\xC", 516 r => "\xD", 517 '\\' => '\\', 518 '"' => '"', 519 '/' => '/', 520 ); 521 522 my $text; # json data 523 my $at; # offset 524 my $ch; # 1chracter 525 my $len; # text length (changed according to UTF8 or NON UTF8) 526 527 my $is_utf8; 528 my $depth; 529 my $encoding; 530 531 my $literal_value; # unmmaping 532 my $utf8; # 533 my $max_depth; # max nest nubmer of objects and arrays 534 my $allow_bigint; # using Math::BigInt 535 my $disable_UTF8; # don't flag UTF8 on 536 my $singlequote; # loosely quoting 537 my $strict; # 538 my $allow_barekey; # bareKey 539 540 my $max_size; 541 my $relaxed; 542 my $cb_object; 543 my $cb_sk_object; 544 545 my $F_HOOK; 546 547 # $opt flag 548 # 0x00000001 .... decode_prefix 549 550 sub decode_json { 551 my ($self, $opt); # $opt is an effective flag during this decode_json. 552 553 ($self, $text, $opt) = @_; 554 555 ($at, $ch, $depth) = (0, '', 0); 556 557 if (!defined $text or ref $text) { 558 decode_error("malformed text data."); 559 } 560 561 $is_utf8 = 1 if (utf8::is_utf8($text)); 562 563 $len = length $text; 564 565 ($utf8, $literal_value, $max_depth, $allow_bigint, $disable_UTF8, $strict, $singlequote, $allow_barekey, 566 $max_size, $relaxed, $cb_object, $cb_sk_object, $F_HOOK) 567 = @{$self}{qw/utf8 literal_value max_depth allow_bigint disable_UTF8 strict singlequote allow_barekey 568 max_size relaxed cb_object cb_sk_object F_HOOK/}; 569 570 if ($max_size and $len > $max_size) { # this lines must be up. 571 decode_error("max_size"); 572 } 573 574 unless ($self->{allow_nonref}) { 575 white(); 576 unless (defined $ch and ($ch eq '{' or $ch eq '[')) { 577 decode_error('JSON text must be an object or array' 578 . ' (but found number, string, true, false or null,' 579 . ' use allow_nonref to allow this)', 1); 580 } 581 } 582 583 # Currently no effective 584 my @octets = unpack('C4', $text); 585 $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' 586 : (!$octets[0] and $octets[1]) ? 'UTF-16BE' 587 : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' 588 : ( $octets[2] ) ? 'UTF-16LE' 589 : (!$octets[2] ) ? 'UTF-32LE' 590 : 'unknown'; 591 592 my $result = value(); 593 594 if ($len >= $at) { 595 my $consumed = $at - 1; 596 white(); 597 if ($ch) { 598 decode_error("garbage after JSON object") unless ($opt & 0x00000001); 599 return ($result, $consumed); 600 } 601 } 602 603 $result; 604 } 605 606 607 sub next_chr { 608 return $ch = undef if($at >= $len); 609 $ch = substr($text, $at++, 1); 610 } 611 612 613 sub value { 614 white(); 615 return if(!defined $ch); 616 return object() if($ch eq '{'); 617 return array() if($ch eq '['); 618 return string() if($ch eq '"' or ($singlequote and $ch eq "'")); 619 return number() if($ch eq '-'); 620 return $ch =~ /\d/ ? number() : word(); 621 } 622 623 624 sub string { 625 my ($i,$s,$t,$u); 626 my @utf16; 627 628 $s = ''; # basically UTF8 flag on 629 630 if($ch eq '"' or ($singlequote and $ch eq "'")){ 631 my $boundChar = $ch if ($singlequote); 632 633 OUTER: while( defined(next_chr()) ){ 634 635 if((!$singlequote and $ch eq '"') or ($singlequote and $ch eq $boundChar)){ 636 next_chr(); 637 638 if (@utf16) { 639 decode_error("missing low surrogate character in surrogate pair"); 640 } 641 642 if($disable_UTF8) { 643 utf8::encode($s) if (utf8::is_utf8($s)); 644 } 645 else { 646 utf8::decode($s); 647 } 648 649 return $s; 650 } 651 elsif($ch eq '\\'){ 652 next_chr(); 653 if(exists $escapes{$ch}){ 654 $s .= $escapes{$ch}; 655 } 656 elsif($ch eq 'u'){ # UNICODE handling 657 my $u = ''; 658 659 for(1..4){ 660 $ch = next_chr(); 661 last OUTER if($ch !~ /[0-9a-fA-F]/); 662 $u .= $ch; 663 } 664 665 $s .= JSON_decode_unicode($u, \@utf16) || next; 666 667 } 668 else{ 669 if ($strict) { 670 decode_error('invalid escaped character'); 671 } 672 $s .= $ch; 673 } 674 } 675 else{ 676 if ($utf8 and $is_utf8) { 677 if( hex(unpack('H*', $ch)) > 255 ) { 678 decode_error("malformed UTF-8 character in JSON string"); 679 } 680 } 681 elsif ($strict) { 682 if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # / ok 683 decode_error('invalid character'); 684 } 685 } 686 687 $s .= $ch; 688 } 689 } 690 } 691 692 if ($relaxed) { # from object(), relaxed 693 if ((( caller(1) )[3]) =~ /object$/ and $ch eq '}') { 694 return; 695 } 696 } 697 698 decode_error("Bad string (unexpected end)"); 699 } 700 701 702 sub white { 703 while( defined $ch ){ 704 if($ch le ' '){ 705 next_chr(); 706 } 707 elsif($ch eq '/'){ 708 next_chr(); 709 if($ch eq '/'){ 710 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); 711 } 712 elsif($ch eq '*'){ 713 next_chr(); 714 while(1){ 715 if(defined $ch){ 716 if($ch eq '*'){ 717 if(defined(next_chr()) and $ch eq '/'){ 718 next_chr(); 719 last; 720 } 721 } 722 else{ 723 next_chr(); 724 } 725 } 726 else{ 727 decode_error("Unterminated comment"); 728 } 729 } 730 next; 731 } 732 else{ 733 decode_error("Syntax decode_error (whitespace)"); 734 } 735 } 736 else{ 737 738 if ($relaxed and $ch eq '#') { 739 pos($text) = $at; 740 $text =~ /\G([^\n]*(?:\r\n|\r|\n))/g; 741 $at = pos($text); 742 next_chr; 743 next; 744 } 745 746 last; 747 } 748 } 749 } 750 751 752 sub object { 753 my $o = {}; 754 my $k; 755 756 if($ch eq '{'){ 757 decode_error('json datastructure exceeds maximum nesting level (set a higher max_depth)') 758 if (++$depth > $max_depth); 759 next_chr(); 760 white(); 761 if(defined $ch and $ch eq '}'){ 762 --$depth; 763 next_chr(); 764 if ($F_HOOK) { 765 return _json_object_hook($o); 766 } 767 return $o; 768 } 769 while(defined $ch){ 770 $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); 771 white(); 772 773 if(!defined $ch or $ch ne ':'){ 774 775 if ($relaxed and $ch eq '}') { # not beautiful... 776 --$depth; 777 next_chr(); 778 if ($F_HOOK) { 779 return _json_object_hook($o); 780 } 781 return $o; 782 } 783 784 decode_error("Bad object ; ':' expected"); 785 } 786 787 next_chr(); 788 $o->{$k} = value(); 789 white(); 790 791 last if (!defined $ch); 792 793 if($ch eq '}'){ 794 --$depth; 795 next_chr(); 796 if ($F_HOOK) { 797 return _json_object_hook($o); 798 } 799 return $o; 800 } 801 elsif($ch ne ','){ 802 last; 803 } 804 805 next_chr(); 806 white(); 807 } 808 809 decode_error("Bad object ; ,or } expected while parsing object/hash"); 810 } 811 } 812 813 814 sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition 815 my $key; 816 while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ 817 $key .= $ch; 818 next_chr(); 819 } 820 return $key; 821 } 822 823 824 sub word { 825 my $word = substr($text,$at-1,4); 826 827 if($word eq 'true'){ 828 $at += 3; 829 next_chr; 830 return $JSON::PP::true; 831 } 832 elsif($word eq 'null'){ 833 $at += 3; 834 next_chr; 835 return undef; 836 } 837 elsif($word eq 'fals'){ 838 $at += 3; 839 if(substr($text,$at,1) eq 'e'){ 840 $at++; 841 next_chr; 842 return $JSON::PP::false; 843 } 844 } 845 846 if ($relaxed) { # from array(), relaxed 847 if ((( caller(2) )[3]) =~ /array$/ and $ch eq ']') { 848 return; 849 } 850 } 851 852 853 $at--; # for decode_error report 854 855 decode_error("Syntax decode_error (word) 'null' expected") if ($word =~ /^n/); 856 decode_error("Syntax decode_error (word) 'true' expected") if ($word =~ /^t/); 857 decode_error("Syntax decode_error (word) 'false' expected") if ($word =~ /^f/); 858 decode_error("Syntax decode_error (word)" . 859 " malformed json string, neither array, object, number, string or atom"); 860 } 861 862 863 sub number { 864 my $n = ''; 865 my $v; 866 867 # According to RFC4627, hex or oct digts are invalid. 868 if($ch eq '0'){ 869 my $peek = substr($text,$at,1); 870 my $hex = $peek =~ /[xX]/; # 0 or 1 871 872 if($hex){ 873 decode_error("malformed number (leading zero must not be followed by another digit)"); 874 ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); 875 } 876 else{ # oct 877 ($n) = ( substr($text, $at) =~ /^([0-7]+)/); 878 if (defined $n and length $n > 1) { 879 decode_error("malformed number (leading zero must not be followed by another digit)"); 880 } 881 } 882 883 if(defined $n and length($n)){ 884 if (!$hex and length($n) == 1) { 885 decode_error("malformed number (leading zero must not be followed by another digit)"); 886 } 887 $at += length($n) + $hex; 888 next_chr; 889 return $hex ? hex($n) : oct($n); 890 } 891 } 892 893 if($ch eq '-'){ 894 $n = '-'; 895 next_chr; 896 if (!defined $ch or $ch !~ /\d/) { 897 decode_error("malformed number (no digits after initial minus)"); 898 } 899 } 900 901 while(defined $ch and $ch =~ /\d/){ 902 $n .= $ch; 903 next_chr; 904 } 905 906 if(defined $ch and $ch eq '.'){ 907 $n .= '.'; 908 909 next_chr; 910 if (!defined $ch or $ch !~ /\d/) { 911 decode_error("malformed number (no digits after decimal point)"); 912 } 913 else { 914 $n .= $ch; 915 } 916 917 while(defined(next_chr) and $ch =~ /\d/){ 918 $n .= $ch; 919 } 920 } 921 922 if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ 923 $n .= $ch; 924 next_chr; 925 926 if(defined($ch) and ($ch eq '+' or $ch eq '-')){ 927 $n .= $ch; 928 next_chr; 929 if (!defined $ch or $ch =~ /\D/) { 930 decode_error("malformed number (no digits after exp sign)"); 931 } 932 $n .= $ch; 933 } 934 elsif(defined($ch) and $ch =~ /\d/){ 935 $n .= $ch; 936 } 937 else { 938 decode_error("malformed number (no digits after exp sign)"); 939 } 940 941 while(defined(next_chr) and $ch =~ /\d/){ 942 $n .= $ch; 943 } 944 945 } 946 947 $v .= $n; 948 949 if ($allow_bigint) { # from Adam Sussman 950 require Math::BigInt; 951 return Math::BigInt->new($v) if ($v !~ /[.eE]/ and length $v > $max_intsize); 952 } 953 954 return 0+$v; 955 } 956 957 958 sub array { 959 my $a = []; 960 961 if ($ch eq '[') { 962 decode_error('json datastructure exceeds maximum nesting level (set a higher max_depth)') 963 if (++$depth > $max_depth); 964 next_chr(); 965 white(); 966 if(defined $ch and $ch eq ']'){ 967 --$depth; 968 next_chr(); 969 return $a; 970 } 971 972 while(defined($ch)){ 973 push @$a, value(); 974 975 white(); 976 977 if (!defined $ch) { 978 last; 979 } 980 981 if($ch eq ']'){ 982 --$depth; 983 next_chr(); 984 return $a; 985 } 986 elsif($ch ne ','){ 987 last; 988 } 989 990 next_chr(); 991 white(); 992 } 993 994 } 995 996 decode_error(", or ] expected while parsing array"); 997 } 998 999 1000 sub decode_error { 1001 my $error = shift; 1002 my $no_rep = shift; 1003 my $str = defined $text ? substr($text, $at) : ''; 1004 1005 unless (length $str) { $str = '(end of string)'; } 1006 1007 if ($no_rep) { 1008 Carp::croak "$error"; 1009 } 1010 else { 1011 Carp::croak "$error, at character offset $at [\"$str\"]"; 1012 } 1013 } 1014 1015 sub _json_object_hook { 1016 my $o = $_[0]; 1017 my @ks = keys %{$o}; 1018 1019 if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { 1020 my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); 1021 if (@val == 1) { 1022 return $val[0]; 1023 } 1024 } 1025 1026 my @val = $cb_object->($o) if ($cb_object); 1027 if (@val == 0 or @val > 1) { 1028 return $o; 1029 } 1030 else { 1031 return $val[0]; 1032 } 1033 } 1034 1035} # PARSE 1036 1037 1038sub _decode_unicode { 1039 my $u = $_[0]; 1040 my $utf16 = $_[1]; 1041 1042 # U+10000 - U+10FFFF 1043 1044 # U+D800 - U+DBFF 1045 if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? 1046 push @$utf16, $u; 1047 } 1048 # U+DC00 - U+DFFF 1049 elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? 1050 unless (scalar(@$utf16)) { 1051 decode_error("missing high surrogate character in surrogate pair"); 1052 } 1053 my $str = pack('H4H4', @$utf16, $u); 1054 @$utf16 = (); 1055 return Encode::decode('UTF-16BE', $str); # UTF-8 flag on 1056 } 1057 else { 1058 if (scalar(@$utf16)) { 1059 decode_error("surrogate pair expected"); 1060 } 1061 1062 return chr(hex($u)); 1063 } 1064 1065 return; 1066} 1067 1068 1069############################### 1070# Utilities 1071# 1072 1073BEGIN { 1074 eval 'require Scalar::Util'; 1075 unless($@){ 1076 *JSON::PP::blessed = \&Scalar::Util::blessed; 1077 } 1078 else{ # This code is from Sclar::Util. 1079 # warn $@; 1080 eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; 1081 *JSON::PP::blessed = sub { 1082 local($@, $SIG{__DIE__}, $SIG{__WARN__}); 1083 ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; 1084 }; 1085 } 1086} 1087 1088 1089 1090 1091# shamely copied and modified from JSON::XS code. 1092 1093$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; 1094$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; 1095 1096sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } 1097 1098sub true { $JSON::PP::true } 1099sub false { $JSON::PP::false } 1100sub null { undef; } 1101 1102############################### 1103 1104# must be removed 1105 1106sub JSON::true () { $JSON::PP::true; } 1107 1108sub JSON::false () { $JSON::PP::false; } 1109 1110sub JSON::null () { undef; } 1111 1112############################### 1113 1114package JSON::PP::Boolean; 1115 1116use overload 1117 "0+" => sub { ${$_[0]} }, 1118 "++" => sub { $_[0] = ${$_[0]} + 1 }, 1119 "--" => sub { $_[0] = ${$_[0]} - 1 }, 1120 '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' }, 1121 1122 'eq' => \&comp, 1123 1124 fallback => 1; 1125 1126 1127sub comp { 1128 my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]); 1129 if ($op eq 'true' or $op eq 'false') { 1130 return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op; 1131 } 1132 else { 1133 return $obj ? 1 == $op : 0 == $op; 1134 } 1135} 1136 1137 1138 1139############################### 1140 1141 11421; 1143__END__ 1144=pod 1145 1146=head1 NAME 1147 1148JSON::PP - An experimental JSON::XS compatible Pure Perl module. 1149 1150=head1 SYNOPSIS 1151 1152 use JSON::PP; 1153 1154 $obj = from_json($json_text); 1155 $json_text = to_json($obj); 1156 1157 # or 1158 1159 $obj = jsonToObj($json_text); 1160 $json_text = objToJson($obj); 1161 1162 $json = new JSON; 1163 $json_text = $json->ascii->pretty($obj); 1164 1165 # you can set options to functions. 1166 1167 $json_text = to_json($obj, {ascii => 1, intend => 2}); 1168 $obj = from_json($json_text, {utf8 => 0}); 1169 1170 1171=head1 DESCRIPTION 1172 1173This module is L<JSON::XS> compatible Pure Perl module. 1174( Perl better than 5.008 is recommended) 1175 1176Module variables ($JSON::*) were abolished. 1177 1178JSON::PP will be renamed JSON (JSON-2.0). 1179 1180Many things including error handling are learned from L<JSON::XS>. 1181For t/02_error.t compatible, error messages was copied partially from JSON::XS. 1182 1183 1184=head2 FEATURES 1185 1186=over 1187 1188=item * perhaps correct unicode handling 1189 1190This module knows how to handle Unicode (perhaps), 1191but not yet documents how and when it does so. 1192 1193In Perl5.6x, Unicode handling requires L<Unicode::String> module. 1194 1195Perl 5.005_xx, Unicode handling is disable currenlty. 1196 1197 1198=item * round-trip integrity 1199 1200This module solved the problem pointed out by JSON::XS 1201using L<B> module. 1202 1203=item * strict checking of JSON correctness 1204 1205I want to bring close to XS. 1206How do you want to carry out? 1207 1208you can set C<strict> decoding method. 1209 1210=item * slow 1211 1212Compared to other JSON modules, this module does not compare 1213favourably in terms of speed. Very slowly! 1214 1215=item * simple to use 1216 1217This module became very simple. 1218Since its interface were anyway made the same as JSON::XS. 1219 1220 1221=item * reasonably versatile output formats 1222 1223See to L<JSON::XS>. 1224 1225=back 1226 1227=head1 FUNCTIONS 1228 1229=over 1230 1231=item to_json 1232 1233See to JSON::XS. 1234C<objToJson> is an alias. 1235 1236=item from_json 1237 1238See to JSON::XS. 1239C<jsonToObj> is an alias. 1240 1241 1242=item JSON::PP::true 1243 1244Returns JSON true value which is blessed object. 1245It C<isa> JSON::PP::Boolean object. 1246 1247=item JSON::PP::false 1248 1249Returns JSON false value which is blessed object. 1250It C<isa> JSON::PP::Boolean object. 1251 1252 1253=item JSON::PP::null 1254 1255Returns C<undef>. 1256 1257 1258=back 1259 1260 1261=head1 METHODS 1262 1263=over 1264 1265=item new 1266 1267Returns JSON::PP object. 1268 1269=item ascii 1270 1271See to JSON::XS. 1272 1273In Perl 5.6, this method requires L<Unicode::String>. 1274If you don't have Unicode::String, 1275the method is always set to false and warns. 1276 1277In Perl 5.005, this option is currently disable. 1278 1279 1280=item latin1 1281 1282See to JSON::XS. 1283 1284In Perl 5.6, this method requires L<Unicode::String>. 1285If you don't have Unicode::String, 1286the method is always set to false and warns. 1287 1288In Perl 5.005, this option is currently disable. 1289 1290 1291=item utf8 1292 1293See to JSON::XS. 1294 1295Currently this module always handles UTF-16 as UTF-16BE. 1296 1297=item pretty 1298 1299See to JSON::XS. 1300 1301=item indent 1302 1303See to JSON::XS. 1304Strictly, this module does not carry out equivalent to XS. 1305 1306 $json->indent(4); 1307 1308is not the same as this: 1309 1310 $json->indent(); 1311 1312 1313=item space_before 1314 1315See to JSON::XS. 1316 1317=item space_after 1318 1319See JSON::XS. 1320 1321=item canonical 1322 1323See to JSON::XS. 1324Strictly, this module does not carry out equivalent to XS. 1325This method can take a subref for sorting (see to L<JSON>). 1326 1327 1328=item allow_nonref 1329 1330See to JSON::XS. 1331 1332=item shrink 1333 1334Not yet implemented. 1335 1336=item max_depth 1337 1338See to JSON::XS. 1339Strictly, this module does not carry out equivalent to XS. 1340By default, 512. 1341 1342When a large value is set, it may raise a warning 'Deep recursion on subroutin'. 1343 1344 1345=item max_size 1346 1347 1348=item relaxed 1349 1350 1351=item allow_blessed 1352 1353 1354=item convert_blessed 1355 1356 1357=item filter_json_object 1358 1359 1360=item filter_json_single_key_object 1361 1362 1363 1364=item encode 1365 1366See to JSON::XS. 1367 1368=item decode 1369 1370See to JSON::XS. 1371In Perl 5.6, if you don't have Unicode::String, 1372the method can't handle UTF-16(BE) char and returns as is. 1373 1374 1375=item property 1376 1377Accessor. 1378 1379 $json->property(utf8 => 1); # $json->utf8(1); 1380 1381 $value = $json->property('utf8'); # returns 1. 1382 1383 1384=item self_encode 1385 1386See L<JSON/BLESSED OBJECT>'s I<self convert> function. 1387 1388Will be obsoleted. 1389 1390 1391=item disable_UTF8 1392 1393If this option is set, UTF8 flag in strings generated 1394by C<encode>/C<decode> is off. 1395 1396 1397=item allow_tied 1398 1399Now disable. 1400 1401 1402=item singlequote 1403 1404Allows to decode single quoted strings. 1405 1406Unlike L<JSON> module, this module does not encode 1407Perl string into single quoted string any longer. 1408 1409 1410=item allow_barekey 1411 1412Allows to decode bare key of member. 1413 1414 1415=item allow_bigint 1416 1417When json text has any integer in decoding more than Perl can't handle, 1418If this option is on, they are converted into L<Math::BigInt> objects. 1419 1420 1421=item strict 1422 1423For JSON format, unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid and 1424JSON::XS decodes just like that (except for \x2f). While this module can deocde thoese. 1425But if this option is set, the module strictly decodes. 1426 1427This option will be obsoleted and 'un-strict' will be added insted. 1428 1429=item escape_slash 1430 1431By default, JSON::PP encodes strings without escaping slash (U+002F). 1432Setting the option to escape slash. 1433 1434 1435 1436 1437=back 1438 1439 1440=head1 MAPPING 1441 1442Now same as JSON::XS. 1443 1444 1445=head1 COMPARISON 1446 1447Using a benchmark program in the JSON::XS (v1.11) distribution. 1448 1449 module | encode | decode | 1450 -----------|------------|------------| 1451 JSON::PP | 11092.260 | 4482.033 | 1452 -----------+------------+------------+ 1453 JSON::XS | 341513.380 | 226138.509 | 1454 -----------+------------+------------+ 1455 1456In case t/12_binary.t (JSON::XS distribution). 1457(shrink of JSON::PP has no effect.) 1458 1459JSON::PP takes 147 (sec). 1460 1461JSON::XS takes 4. 1462 1463 1464=head1 TODO 1465 1466=over 1467 1468=item Document! 1469 1470It is troublesome. 1471 1472=item clean up 1473 1474Under the cleaning. 1475 1476=back 1477 1478 1479=head1 SEE ALSO 1480 1481L<JSON>, L<JSON::XS> 1482 1483RFC4627 1484 1485=head1 AUTHOR 1486 1487Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> 1488 1489 1490=head1 COPYRIGHT AND LICENSE 1491 1492Copyright 2007 by Makamaka Hannyaharamitu 1493 1494This library is free software; you can redistribute it and/or modify 1495it under the same terms as Perl itself. 1496 1497=cut 1498