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