Filename | /usr/share/perl5/vendor_perl/JSON/PP.pm |
Statements | Executed 239 statements in 11.9ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 2.57ms | 3.27ms | BEGIN@11 | JSON::PP::
1 | 1 | 1 | 2.13ms | 2.13ms | BEGIN@45 | JSON::PP::
1 | 1 | 1 | 286µs | 286µs | BEGIN@584 | JSON::PP::
1 | 1 | 1 | 85µs | 85µs | BEGIN@1273 | JSON::PP::
1 | 1 | 1 | 47µs | 47µs | BEGIN@5 | JSON::PP::
1 | 1 | 1 | 32µs | 32µs | BEGIN@1336 | JSON::PP::
1 | 1 | 1 | 22µs | 34µs | pretty | JSON::PP::
1 | 1 | 1 | 20µs | 60µs | BEGIN@1407 | JSON::PP::Boolean::
1 | 1 | 1 | 19µs | 19µs | new | JSON::PP::
1 | 1 | 1 | 16µs | 45µs | BEGIN@30 | JSON::PP::
1 | 1 | 1 | 14µs | 16µs | BEGIN@666 | JSON::PP::
1 | 1 | 1 | 13µs | 42µs | BEGIN@32 | JSON::PP::
1 | 1 | 1 | 13µs | 44µs | BEGIN@22 | JSON::PP::
1 | 1 | 1 | 12µs | 29µs | BEGIN@6 | JSON::PP::
1 | 1 | 1 | 12µs | 52µs | BEGIN@21 | JSON::PP::
1 | 1 | 1 | 11µs | 38µs | BEGIN@36 | JSON::PP::
1 | 1 | 1 | 10µs | 45µs | BEGIN@1426 | JSON::PP::IncrParser::
1 | 1 | 1 | 10µs | 25µs | BEGIN@1419 | JSON::PP::IncrParser::
1 | 1 | 1 | 10µs | 46µs | BEGIN@1422 | JSON::PP::IncrParser::
1 | 1 | 1 | 10µs | 39µs | BEGIN@26 | JSON::PP::
1 | 1 | 1 | 10µs | 96µs | BEGIN@7 | JSON::PP::
1 | 1 | 1 | 9µs | 38µs | BEGIN@43 | JSON::PP::
1 | 1 | 1 | 9µs | 44µs | BEGIN@1421 | JSON::PP::IncrParser::
1 | 1 | 1 | 9µs | 38µs | BEGIN@31 | JSON::PP::
1 | 1 | 1 | 9µs | 39µs | BEGIN@1423 | JSON::PP::IncrParser::
1 | 1 | 1 | 9µs | 38µs | BEGIN@29 | JSON::PP::
1 | 1 | 1 | 9µs | 38µs | BEGIN@41 | JSON::PP::
1 | 1 | 1 | 9µs | 37µs | BEGIN@24 | JSON::PP::
1 | 1 | 1 | 9µs | 38µs | BEGIN@27 | JSON::PP::
1 | 1 | 1 | 9µs | 38µs | BEGIN@28 | JSON::PP::
1 | 1 | 1 | 9µs | 37µs | BEGIN@25 | JSON::PP::
1 | 1 | 1 | 9µs | 44µs | BEGIN@1425 | JSON::PP::IncrParser::
1 | 1 | 1 | 9µs | 37µs | BEGIN@1424 | JSON::PP::IncrParser::
1 | 1 | 1 | 8µs | 38µs | BEGIN@23 | JSON::PP::
1 | 1 | 1 | 8µs | 36µs | BEGIN@37 | JSON::PP::
1 | 1 | 1 | 8µs | 37µs | BEGIN@34 | JSON::PP::
1 | 1 | 1 | 8µs | 35µs | BEGIN@35 | JSON::PP::
1 | 1 | 1 | 8µs | 36µs | BEGIN@39 | JSON::PP::
1 | 1 | 1 | 8µs | 36µs | BEGIN@38 | JSON::PP::
1 | 1 | 1 | 4µs | 4µs | BEGIN@8 | JSON::PP::
1 | 1 | 1 | 4µs | 4µs | BEGIN@10 | JSON::PP::
0 | 0 | 0 | 0s | 0s | __ANON__[:1408] | JSON::PP::Boolean::
0 | 0 | 0 | 0s | 0s | __ANON__[:1409] | JSON::PP::Boolean::
0 | 0 | 0 | 0s | 0s | __ANON__[:1410] | JSON::PP::Boolean::
0 | 0 | 0 | 0s | 0s | _incr_parse | JSON::PP::IncrParser::
0 | 0 | 0 | 0s | 0s | incr_parse | JSON::PP::IncrParser::
0 | 0 | 0 | 0s | 0s | incr_reset | JSON::PP::IncrParser::
0 | 0 | 0 | 0s | 0s | incr_skip | JSON::PP::IncrParser::
0 | 0 | 0 | 0s | 0s | incr_text | JSON::PP::IncrParser::
0 | 0 | 0 | 0s | 0s | new | JSON::PP::IncrParser::
0 | 0 | 0 | 0s | 0s | PP_decode_box | JSON::PP::
0 | 0 | 0 | 0s | 0s | PP_decode_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | PP_encode_box | JSON::PP::
0 | 0 | 0 | 0s | 0s | PP_encode_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | __ANON__[:1349] | JSON::PP::
0 | 0 | 0 | 0s | 0s | __ANON__[:134] | JSON::PP::
0 | 0 | 0 | 0s | 0s | __ANON__[:1370] | JSON::PP::
0 | 0 | 0 | 0s | 0s | __ANON__[:1387] | JSON::PP::
0 | 0 | 0 | 0s | 0s | __ANON__[:281] | JSON::PP::
0 | 0 | 0 | 0s | 0s | __ANON__[:286] | JSON::PP::
0 | 0 | 0 | 0s | 0s | _decode_surrogates | JSON::PP::
0 | 0 | 0 | 0s | 0s | _decode_unicode | JSON::PP::
0 | 0 | 0 | 0s | 0s | _down_indent | JSON::PP::
0 | 0 | 0 | 0s | 0s | _encode_ascii | JSON::PP::
0 | 0 | 0 | 0s | 0s | _encode_latin1 | JSON::PP::
0 | 0 | 0 | 0s | 0s | _encode_surrogates | JSON::PP::
0 | 0 | 0 | 0s | 0s | _is_bignum | JSON::PP::
0 | 0 | 0 | 0s | 0s | _json_object_hook | JSON::PP::
0 | 0 | 0 | 0s | 0s | _sort | JSON::PP::
0 | 0 | 0 | 0s | 0s | _up_indent | JSON::PP::
0 | 0 | 0 | 0s | 0s | allow_bigint | JSON::PP::
0 | 0 | 0 | 0s | 0s | array | JSON::PP::
0 | 0 | 0 | 0s | 0s | array_to_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | bareKey | JSON::PP::
0 | 0 | 0 | 0s | 0s | blessed_to_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | decode | JSON::PP::
0 | 0 | 0 | 0s | 0s | decode_error | JSON::PP::
0 | 0 | 0 | 0s | 0s | decode_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | decode_prefix | JSON::PP::
0 | 0 | 0 | 0s | 0s | encode | JSON::PP::
0 | 0 | 0 | 0s | 0s | encode_error | JSON::PP::
0 | 0 | 0 | 0s | 0s | encode_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | false | JSON::PP::
0 | 0 | 0 | 0s | 0s | filter_json_object | JSON::PP::
0 | 0 | 0 | 0s | 0s | filter_json_single_key_object | JSON::PP::
0 | 0 | 0 | 0s | 0s | from_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | get_indent_length | JSON::PP::
0 | 0 | 0 | 0s | 0s | get_max_depth | JSON::PP::
0 | 0 | 0 | 0s | 0s | get_max_size | JSON::PP::
0 | 0 | 0 | 0s | 0s | hash_to_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | incr_parse | JSON::PP::
0 | 0 | 0 | 0s | 0s | incr_reset | JSON::PP::
0 | 0 | 0 | 0s | 0s | incr_skip | JSON::PP::
0 | 0 | 0 | 0s | 0s | indent_length | JSON::PP::
0 | 0 | 0 | 0s | 0s | is_bool | JSON::PP::
0 | 0 | 0 | 0s | 0s | is_valid_utf8 | JSON::PP::
0 | 0 | 0 | 0s | 0s | max_depth | JSON::PP::
0 | 0 | 0 | 0s | 0s | max_size | JSON::PP::
0 | 0 | 0 | 0s | 0s | next_chr | JSON::PP::
0 | 0 | 0 | 0s | 0s | null | JSON::PP::
0 | 0 | 0 | 0s | 0s | number | JSON::PP::
0 | 0 | 0 | 0s | 0s | object | JSON::PP::
0 | 0 | 0 | 0s | 0s | object_to_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | sort_by | JSON::PP::
0 | 0 | 0 | 0s | 0s | string | JSON::PP::
0 | 0 | 0 | 0s | 0s | string_to_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | to_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | true | JSON::PP::
0 | 0 | 0 | 0s | 0s | value | JSON::PP::
0 | 0 | 0 | 0s | 0s | value_to_json | JSON::PP::
0 | 0 | 0 | 0s | 0s | white | JSON::PP::
0 | 0 | 0 | 0s | 0s | word | JSON::PP::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package JSON::PP; | ||||
2 | |||||
3 | # JSON-2.0 | ||||
4 | |||||
5 | 2 | 89µs | 1 | 47µs | # spent 47µs within JSON::PP::BEGIN@5 which was called:
# once (47µs+0s) by JSON::BEGIN@1 at line 5 # spent 47µs making 1 call to JSON::PP::BEGIN@5 |
6 | 2 | 35µs | 2 | 46µs | # spent 29µs (12+17) within JSON::PP::BEGIN@6 which was called:
# once (12µs+17µs) by JSON::BEGIN@1 at line 6 # spent 29µs making 1 call to JSON::PP::BEGIN@6
# spent 17µs making 1 call to strict::import |
7 | 2 | 32µs | 2 | 182µs | # spent 96µs (10+86) within JSON::PP::BEGIN@7 which was called:
# once (10µs+86µs) by JSON::BEGIN@1 at line 7 # spent 96µs making 1 call to JSON::PP::BEGIN@7
# spent 86µs making 1 call to base::import |
8 | 2 | 26µs | 1 | 4µs | # spent 4µs within JSON::PP::BEGIN@8 which was called:
# once (4µs+0s) by JSON::BEGIN@1 at line 8 # spent 4µs making 1 call to JSON::PP::BEGIN@8 |
9 | |||||
10 | 2 | 23µs | 1 | 4µs | # spent 4µs within JSON::PP::BEGIN@10 which was called:
# once (4µs+0s) by JSON::BEGIN@1 at line 10 # spent 4µs making 1 call to JSON::PP::BEGIN@10 |
11 | 2 | 154µs | 1 | 3.27ms | # spent 3.27ms (2.57+701µs) within JSON::PP::BEGIN@11 which was called:
# once (2.57ms+701µs) by JSON::BEGIN@1 at line 11 # spent 3.27ms making 1 call to JSON::PP::BEGIN@11 |
12 | #use Devel::Peek; | ||||
13 | |||||
14 | 1 | 1µs | $JSON::PP::VERSION = '2.27202'; | ||
15 | |||||
16 | 1 | 2µs | @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 | |||||
21 | 2 | 36µs | 2 | 93µs | # spent 52µs (12+41) within JSON::PP::BEGIN@21 which was called:
# once (12µs+41µs) by JSON::BEGIN@1 at line 21 # spent 52µs making 1 call to JSON::PP::BEGIN@21
# spent 41µs making 1 call to constant::import |
22 | 2 | 34µs | 2 | 75µs | # spent 44µs (13+31) within JSON::PP::BEGIN@22 which was called:
# once (13µs+31µs) by JSON::BEGIN@1 at line 22 # spent 44µs making 1 call to JSON::PP::BEGIN@22
# spent 31µs making 1 call to constant::import |
23 | 2 | 32µs | 2 | 67µs | # spent 38µs (8+29) within JSON::PP::BEGIN@23 which was called:
# once (8µs+29µs) by JSON::BEGIN@1 at line 23 # spent 38µs making 1 call to JSON::PP::BEGIN@23
# spent 29µs making 1 call to constant::import |
24 | 2 | 31µs | 2 | 65µs | # spent 37µs (9+28) within JSON::PP::BEGIN@24 which was called:
# once (9µs+28µs) by JSON::BEGIN@1 at line 24 # spent 37µs making 1 call to JSON::PP::BEGIN@24
# spent 28µs making 1 call to constant::import |
25 | 2 | 45µs | 2 | 66µs | # spent 37µs (9+28) within JSON::PP::BEGIN@25 which was called:
# once (9µs+28µs) by JSON::BEGIN@1 at line 25 # spent 37µs making 1 call to JSON::PP::BEGIN@25
# spent 28µs making 1 call to constant::import |
26 | 2 | 33µs | 2 | 69µs | # spent 39µs (10+30) within JSON::PP::BEGIN@26 which was called:
# once (10µs+30µs) by JSON::BEGIN@1 at line 26 # spent 39µs making 1 call to JSON::PP::BEGIN@26
# spent 30µs making 1 call to constant::import |
27 | 2 | 31µs | 2 | 66µs | # spent 38µs (9+29) within JSON::PP::BEGIN@27 which was called:
# once (9µs+29µs) by JSON::BEGIN@1 at line 27 # spent 38µs making 1 call to JSON::PP::BEGIN@27
# spent 29µs making 1 call to constant::import |
28 | 2 | 31µs | 2 | 67µs | # spent 38µs (9+29) within JSON::PP::BEGIN@28 which was called:
# once (9µs+29µs) by JSON::BEGIN@1 at line 28 # spent 38µs making 1 call to JSON::PP::BEGIN@28
# spent 29µs making 1 call to constant::import |
29 | 2 | 31µs | 2 | 66µs | # spent 38µs (9+29) within JSON::PP::BEGIN@29 which was called:
# once (9µs+29µs) by JSON::BEGIN@1 at line 29 # spent 38µs making 1 call to JSON::PP::BEGIN@29
# spent 29µs making 1 call to constant::import |
30 | 2 | 33µs | 2 | 74µs | # spent 45µs (16+29) within JSON::PP::BEGIN@30 which was called:
# once (16µs+29µs) by JSON::BEGIN@1 at line 30 # spent 45µs making 1 call to JSON::PP::BEGIN@30
# spent 29µs making 1 call to constant::import |
31 | 2 | 31µs | 2 | 67µs | # spent 38µs (9+29) within JSON::PP::BEGIN@31 which was called:
# once (9µs+29µs) by JSON::BEGIN@1 at line 31 # spent 38µs making 1 call to JSON::PP::BEGIN@31
# spent 29µs making 1 call to constant::import |
32 | 2 | 33µs | 2 | 71µs | # spent 42µs (13+29) within JSON::PP::BEGIN@32 which was called:
# once (13µs+29µs) by JSON::BEGIN@1 at line 32 # spent 42µs making 1 call to JSON::PP::BEGIN@32
# spent 29µs making 1 call to constant::import |
33 | |||||
34 | 2 | 30µs | 2 | 65µs | # spent 37µs (8+28) within JSON::PP::BEGIN@34 which was called:
# once (8µs+28µs) by JSON::BEGIN@1 at line 34 # spent 37µs making 1 call to JSON::PP::BEGIN@34
# spent 28µs making 1 call to constant::import |
35 | 2 | 30µs | 2 | 62µs | # spent 35µs (8+27) within JSON::PP::BEGIN@35 which was called:
# once (8µs+27µs) by JSON::BEGIN@1 at line 35 # spent 35µs making 1 call to JSON::PP::BEGIN@35
# spent 27µs making 1 call to constant::import |
36 | 2 | 31µs | 2 | 65µs | # spent 38µs (11+27) within JSON::PP::BEGIN@36 which was called:
# once (11µs+27µs) by JSON::BEGIN@1 at line 36 # spent 38µs making 1 call to JSON::PP::BEGIN@36
# spent 27µs making 1 call to constant::import |
37 | 2 | 30µs | 2 | 65µs | # spent 36µs (8+28) within JSON::PP::BEGIN@37 which was called:
# once (8µs+28µs) by JSON::BEGIN@1 at line 37 # spent 36µs making 1 call to JSON::PP::BEGIN@37
# spent 28µs making 1 call to constant::import |
38 | 2 | 29µs | 2 | 63µs | # spent 36µs (8+28) within JSON::PP::BEGIN@38 which was called:
# once (8µs+28µs) by JSON::BEGIN@1 at line 38 # spent 36µs making 1 call to JSON::PP::BEGIN@38
# spent 28µs making 1 call to constant::import |
39 | 2 | 41µs | 2 | 63µs | # spent 36µs (8+28) within JSON::PP::BEGIN@39 which was called:
# once (8µs+28µs) by JSON::BEGIN@1 at line 39 # spent 36µs making 1 call to JSON::PP::BEGIN@39
# spent 28µs making 1 call to constant::import |
40 | |||||
41 | 2 | 40µs | 2 | 67µs | # spent 38µs (9+29) within JSON::PP::BEGIN@41 which was called:
# once (9µs+29µs) by JSON::BEGIN@1 at line 41 # spent 38µs making 1 call to JSON::PP::BEGIN@41
# spent 29µs making 1 call to constant::import |
42 | |||||
43 | 2 | 162µs | 2 | 66µs | # spent 38µs (9+28) within JSON::PP::BEGIN@43 which was called:
# once (9µs+28µs) by JSON::BEGIN@1 at line 43 # spent 38µs making 1 call to JSON::PP::BEGIN@43
# spent 28µs making 1 call to constant::import |
44 | |||||
45 | # spent 2.13ms within JSON::PP::BEGIN@45 which was called:
# once (2.13ms+0s) by JSON::BEGIN@1 at line 86 | ||||
46 | 1 | 4µs | my @xs_compati_bit_properties = qw( | ||
47 | latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink | ||||
48 | allow_blessed convert_blessed relaxed allow_unknown | ||||
49 | ); | ||||
50 | 1 | 5µs | my @pp_bit_properties = qw( | ||
51 | allow_singlequote allow_bignum loose | ||||
52 | allow_barekey escape_slash as_nonblessed | ||||
53 | ); | ||||
54 | |||||
55 | # Perl version check, Unicode handling is enable? | ||||
56 | # Helper module sets @JSON::PP::_properties. | ||||
57 | 1 | 1µs | if ($] < 5.008 ) { | ||
58 | my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005'; | ||||
59 | eval qq| require $helper |; | ||||
60 | if ($@) { Carp::croak $@; } | ||||
61 | } | ||||
62 | |||||
63 | 1 | 9µs | for my $name (@xs_compati_bit_properties, @pp_bit_properties) { | ||
64 | 19 | 19µs | my $flag_name = 'P_' . uc($name); | ||
65 | |||||
66 | 19 | 2.09ms | eval qq/ # spent 7µs executing statements in string eval # includes 6µs spent executing 1 call to 2 subs defined therein. # spent 6µs executing statements in string eval # includes 4µs spent executing 1 call to 2 subs defined therein. # spent 6µs executing statements in string eval # includes 4µs spent executing 1 call to 2 subs defined therein. # spent 5µs executing statements in string eval # includes 4µs spent executing 1 call to 2 subs defined therein. # spent 0s executing statements in string eval | ||
67 | sub $name { | ||||
68 | my \$enable = defined \$_[1] ? \$_[1] : 1; | ||||
69 | |||||
70 | if (\$enable) { | ||||
71 | \$_[0]->{PROPS}->[$flag_name] = 1; | ||||
72 | } | ||||
73 | else { | ||||
74 | \$_[0]->{PROPS}->[$flag_name] = 0; | ||||
75 | } | ||||
76 | |||||
77 | \$_[0]; | ||||
78 | } | ||||
79 | |||||
80 | sub get_$name { | ||||
81 | \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; | ||||
82 | } | ||||
83 | /; | ||||
84 | } | ||||
85 | |||||
86 | 1 | 2.92ms | 1 | 2.13ms | } # spent 2.13ms making 1 call to JSON::PP::BEGIN@45 |
87 | |||||
- - | |||||
90 | # Functions | ||||
91 | |||||
92 | my %encode_allow_method | ||||
93 | 1 | 13µs | = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash | ||
94 | allow_blessed convert_blessed indent indent_length allow_bignum | ||||
95 | as_nonblessed | ||||
96 | /; | ||||
97 | my %decode_allow_method | ||||
98 | 1 | 6µs | = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum | ||
99 | allow_barekey max_size relaxed/; | ||||
100 | |||||
101 | |||||
102 | 1 | 200ns | my $JSON; # cache | ||
103 | |||||
104 | sub encode_json ($) { # encode | ||||
105 | ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); | ||||
106 | } | ||||
107 | |||||
108 | |||||
109 | sub decode_json { # decode | ||||
110 | ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); | ||||
111 | } | ||||
112 | |||||
113 | # Obsoleted | ||||
114 | |||||
115 | sub to_json($) { | ||||
116 | Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); | ||||
117 | } | ||||
118 | |||||
119 | |||||
120 | sub from_json($) { | ||||
121 | Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); | ||||
122 | } | ||||
123 | |||||
124 | |||||
125 | # Methods | ||||
126 | |||||
127 | # spent 19µs within JSON::PP::new which was called:
# once (19µs+0s) by Foswiki::Store::Rcs::RcsWrapHandler::BEGIN@23 at line 67 of /var/www/foswikidev/core/lib/Foswiki/Store/Rcs/Handler.pm | ||||
128 | 1 | 1µs | my $class = shift; | ||
129 | my $self = { | ||||
130 | max_depth => 512, | ||||
131 | max_size => 0, | ||||
132 | indent => 0, | ||||
133 | FLAGS => 0, | ||||
134 | fallback => sub { encode_error('Invalid value. JSON can only reference.') }, | ||||
135 | 1 | 8µs | indent_length => 3, | ||
136 | }; | ||||
137 | |||||
138 | 1 | 14µs | bless $self, $class; | ||
139 | } | ||||
140 | |||||
141 | |||||
142 | sub encode { | ||||
143 | return $_[0]->PP_encode_json($_[1]); | ||||
144 | } | ||||
145 | |||||
146 | |||||
147 | sub decode { | ||||
148 | return $_[0]->PP_decode_json($_[1], 0x00000000); | ||||
149 | } | ||||
150 | |||||
151 | |||||
152 | sub decode_prefix { | ||||
153 | return $_[0]->PP_decode_json($_[1], 0x00000001); | ||||
154 | } | ||||
155 | |||||
156 | |||||
157 | # accessor | ||||
158 | |||||
159 | |||||
160 | # pretty printing | ||||
161 | |||||
162 | # spent 34µs (22+12) within JSON::PP::pretty which was called:
# once (22µs+12µs) by Foswiki::Store::Rcs::RcsWrapHandler::BEGIN@23 at line 67 of /var/www/foswikidev/core/lib/Foswiki/Store/Rcs/Handler.pm | ||||
163 | 1 | 1µs | my ($self, $v) = @_; | ||
164 | 1 | 600ns | my $enable = defined $v ? $v : 1; | ||
165 | |||||
166 | 1 | 700ns | if ($enable) { # indent_length(3) for JSON::XS compatibility | ||
167 | $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); | ||||
168 | } | ||||
169 | else { | ||||
170 | 1 | 13µs | 3 | 12µs | $self->indent(0)->space_before(0)->space_after(0); # spent 4µs making 1 call to JSON::PP::indent
# spent 4µs making 1 call to JSON::PP::space_before
# spent 4µs making 1 call to JSON::PP::space_after |
171 | } | ||||
172 | |||||
173 | 1 | 3µs | $self; | ||
174 | } | ||||
175 | |||||
176 | # etc | ||||
177 | |||||
178 | sub max_depth { | ||||
179 | my $max = defined $_[1] ? $_[1] : 0x80000000; | ||||
180 | $_[0]->{max_depth} = $max; | ||||
181 | $_[0]; | ||||
182 | } | ||||
183 | |||||
184 | |||||
185 | sub get_max_depth { $_[0]->{max_depth}; } | ||||
186 | |||||
187 | |||||
188 | sub max_size { | ||||
189 | my $max = defined $_[1] ? $_[1] : 0; | ||||
190 | $_[0]->{max_size} = $max; | ||||
191 | $_[0]; | ||||
192 | } | ||||
193 | |||||
194 | |||||
195 | sub get_max_size { $_[0]->{max_size}; } | ||||
196 | |||||
197 | |||||
198 | sub filter_json_object { | ||||
199 | $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; | ||||
200 | $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; | ||||
201 | $_[0]; | ||||
202 | } | ||||
203 | |||||
204 | sub filter_json_single_key_object { | ||||
205 | if (@_ > 1) { | ||||
206 | $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; | ||||
207 | } | ||||
208 | $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; | ||||
209 | $_[0]; | ||||
210 | } | ||||
211 | |||||
212 | sub indent_length { | ||||
213 | if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { | ||||
214 | Carp::carp "The acceptable range of indent_length() is 0 to 15."; | ||||
215 | } | ||||
216 | else { | ||||
217 | $_[0]->{indent_length} = $_[1]; | ||||
218 | } | ||||
219 | $_[0]; | ||||
220 | } | ||||
221 | |||||
222 | sub get_indent_length { | ||||
223 | $_[0]->{indent_length}; | ||||
224 | } | ||||
225 | |||||
226 | sub sort_by { | ||||
227 | $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; | ||||
228 | $_[0]; | ||||
229 | } | ||||
230 | |||||
231 | sub allow_bigint { | ||||
232 | Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); | ||||
233 | } | ||||
234 | |||||
235 | ############################### | ||||
236 | |||||
237 | ### | ||||
238 | ### Perl => JSON | ||||
239 | ### | ||||
240 | |||||
241 | |||||
242 | { # Convert | ||||
243 | |||||
244 | 2 | 500ns | my $max_depth; | ||
245 | 1 | 0s | my $indent; | ||
246 | 1 | 100ns | my $ascii; | ||
247 | 1 | 100ns | my $latin1; | ||
248 | 1 | 100ns | my $utf8; | ||
249 | 1 | 0s | my $space_before; | ||
250 | 1 | 100ns | my $space_after; | ||
251 | 1 | 100ns | my $canonical; | ||
252 | 1 | 100ns | my $allow_blessed; | ||
253 | 1 | 100ns | my $convert_blessed; | ||
254 | |||||
255 | 1 | 100ns | my $indent_length; | ||
256 | 1 | 100ns | my $escape_slash; | ||
257 | 1 | 100ns | my $bignum; | ||
258 | 1 | 0s | my $as_nonblessed; | ||
259 | |||||
260 | 1 | 0s | my $depth; | ||
261 | 1 | 0s | my $indent_count; | ||
262 | 1 | 100ns | my $keysort; | ||
263 | |||||
264 | |||||
265 | sub PP_encode_json { | ||||
266 | my $self = shift; | ||||
267 | my $obj = shift; | ||||
268 | |||||
269 | $indent_count = 0; | ||||
270 | $depth = 0; | ||||
271 | |||||
272 | my $idx = $self->{PROPS}; | ||||
273 | |||||
274 | ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, | ||||
275 | $convert_blessed, $escape_slash, $bignum, $as_nonblessed) | ||||
276 | = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, | ||||
277 | P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; | ||||
278 | |||||
279 | ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; | ||||
280 | |||||
281 | $keysort = $canonical ? sub { $a cmp $b } : undef; | ||||
282 | |||||
283 | if ($self->{sort_by}) { | ||||
284 | $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} | ||||
285 | : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} | ||||
286 | : sub { $a cmp $b }; | ||||
287 | } | ||||
288 | |||||
289 | encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") | ||||
290 | if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); | ||||
291 | |||||
292 | my $str = $self->object_to_json($obj); | ||||
293 | |||||
294 | $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible | ||||
295 | |||||
296 | unless ($ascii or $latin1 or $utf8) { | ||||
297 | utf8::upgrade($str); | ||||
298 | } | ||||
299 | |||||
300 | if ($idx->[ P_SHRINK ]) { | ||||
301 | utf8::downgrade($str, 1); | ||||
302 | } | ||||
303 | |||||
304 | return $str; | ||||
305 | } | ||||
306 | |||||
307 | |||||
308 | sub object_to_json { | ||||
309 | my ($self, $obj) = @_; | ||||
310 | my $type = ref($obj); | ||||
311 | |||||
312 | if($type eq 'HASH'){ | ||||
313 | return $self->hash_to_json($obj); | ||||
314 | } | ||||
315 | elsif($type eq 'ARRAY'){ | ||||
316 | return $self->array_to_json($obj); | ||||
317 | } | ||||
318 | elsif ($type) { # blessed object? | ||||
319 | if (blessed($obj)) { | ||||
320 | |||||
321 | return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); | ||||
322 | |||||
323 | if ( $convert_blessed and $obj->can('TO_JSON') ) { | ||||
324 | my $result = $obj->TO_JSON(); | ||||
325 | if ( defined $result and ref( $result ) ) { | ||||
326 | if ( refaddr( $obj ) eq refaddr( $result ) ) { | ||||
327 | encode_error( sprintf( | ||||
328 | "%s::TO_JSON method returned same object as was passed instead of a new one", | ||||
329 | ref $obj | ||||
330 | ) ); | ||||
331 | } | ||||
332 | } | ||||
333 | |||||
334 | return $self->object_to_json( $result ); | ||||
335 | } | ||||
336 | |||||
337 | return "$obj" if ( $bignum and _is_bignum($obj) ); | ||||
338 | return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. | ||||
339 | |||||
340 | encode_error( sprintf("encountered object '%s', but neither allow_blessed " | ||||
341 | . "nor convert_blessed settings are enabled", $obj) | ||||
342 | ) unless ($allow_blessed); | ||||
343 | |||||
344 | return 'null'; | ||||
345 | } | ||||
346 | else { | ||||
347 | return $self->value_to_json($obj); | ||||
348 | } | ||||
349 | } | ||||
350 | else{ | ||||
351 | return $self->value_to_json($obj); | ||||
352 | } | ||||
353 | } | ||||
354 | |||||
355 | |||||
356 | sub hash_to_json { | ||||
357 | my ($self, $obj) = @_; | ||||
358 | my @res; | ||||
359 | |||||
360 | encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") | ||||
361 | if (++$depth > $max_depth); | ||||
362 | |||||
363 | my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); | ||||
364 | my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); | ||||
365 | |||||
366 | for my $k ( _sort( $obj ) ) { | ||||
367 | if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized | ||||
368 | push @res, string_to_json( $self, $k ) | ||||
369 | . $del | ||||
370 | . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); | ||||
371 | } | ||||
372 | |||||
373 | --$depth; | ||||
374 | $self->_down_indent() if ($indent); | ||||
375 | |||||
376 | return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; | ||||
377 | } | ||||
378 | |||||
379 | |||||
380 | sub array_to_json { | ||||
381 | my ($self, $obj) = @_; | ||||
382 | my @res; | ||||
383 | |||||
384 | encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") | ||||
385 | if (++$depth > $max_depth); | ||||
386 | |||||
387 | my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); | ||||
388 | |||||
389 | for my $v (@$obj){ | ||||
390 | push @res, $self->object_to_json($v) || $self->value_to_json($v); | ||||
391 | } | ||||
392 | |||||
393 | --$depth; | ||||
394 | $self->_down_indent() if ($indent); | ||||
395 | |||||
396 | return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; | ||||
397 | } | ||||
398 | |||||
399 | |||||
400 | sub value_to_json { | ||||
401 | my ($self, $value) = @_; | ||||
402 | |||||
403 | return 'null' if(!defined $value); | ||||
404 | |||||
405 | my $b_obj = B::svref_2object(\$value); # for round trip problem | ||||
406 | my $flags = $b_obj->FLAGS; | ||||
407 | |||||
408 | return $value # as is | ||||
409 | if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? | ||||
410 | |||||
411 | my $type = ref($value); | ||||
412 | |||||
413 | if(!$type){ | ||||
414 | return string_to_json($self, $value); | ||||
415 | } | ||||
416 | elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ | ||||
417 | return $$value == 1 ? 'true' : 'false'; | ||||
418 | } | ||||
419 | elsif ($type) { | ||||
420 | if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { | ||||
421 | return $self->value_to_json("$value"); | ||||
422 | } | ||||
423 | |||||
424 | if ($type eq 'SCALAR' and defined $$value) { | ||||
425 | return $$value eq '1' ? 'true' | ||||
426 | : $$value eq '0' ? 'false' | ||||
427 | : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' | ||||
428 | : encode_error("cannot encode reference to scalar"); | ||||
429 | } | ||||
430 | |||||
431 | if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { | ||||
432 | return 'null'; | ||||
433 | } | ||||
434 | else { | ||||
435 | if ( $type eq 'SCALAR' or $type eq 'REF' ) { | ||||
436 | encode_error("cannot encode reference to scalar"); | ||||
437 | } | ||||
438 | else { | ||||
439 | encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); | ||||
440 | } | ||||
441 | } | ||||
442 | |||||
443 | } | ||||
444 | else { | ||||
445 | return $self->{fallback}->($value) | ||||
446 | if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); | ||||
447 | return 'null'; | ||||
448 | } | ||||
449 | |||||
450 | } | ||||
451 | |||||
452 | |||||
453 | 1 | 4µs | my %esc = ( | ||
454 | "\n" => '\n', | ||||
455 | "\r" => '\r', | ||||
456 | "\t" => '\t', | ||||
457 | "\f" => '\f', | ||||
458 | "\b" => '\b', | ||||
459 | "\"" => '\"', | ||||
460 | "\\" => '\\\\', | ||||
461 | "\'" => '\\\'', | ||||
462 | ); | ||||
463 | |||||
464 | |||||
465 | sub string_to_json { | ||||
466 | my ($self, $arg) = @_; | ||||
467 | |||||
468 | $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; | ||||
469 | $arg =~ s/\//\\\//g if ($escape_slash); | ||||
470 | $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; | ||||
471 | |||||
472 | if ($ascii) { | ||||
473 | $arg = JSON_PP_encode_ascii($arg); | ||||
474 | } | ||||
475 | |||||
476 | if ($latin1) { | ||||
477 | $arg = JSON_PP_encode_latin1($arg); | ||||
478 | } | ||||
479 | |||||
480 | if ($utf8) { | ||||
481 | utf8::encode($arg); | ||||
482 | } | ||||
483 | |||||
484 | return '"' . $arg . '"'; | ||||
485 | } | ||||
486 | |||||
487 | |||||
488 | sub blessed_to_json { | ||||
489 | my $reftype = reftype($_[1]) || ''; | ||||
490 | if ($reftype eq 'HASH') { | ||||
491 | return $_[0]->hash_to_json($_[1]); | ||||
492 | } | ||||
493 | elsif ($reftype eq 'ARRAY') { | ||||
494 | return $_[0]->array_to_json($_[1]); | ||||
495 | } | ||||
496 | else { | ||||
497 | return 'null'; | ||||
498 | } | ||||
499 | } | ||||
500 | |||||
501 | |||||
502 | sub encode_error { | ||||
503 | my $error = shift; | ||||
504 | Carp::croak "$error"; | ||||
505 | } | ||||
506 | |||||
507 | |||||
508 | sub _sort { | ||||
509 | defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; | ||||
510 | } | ||||
511 | |||||
512 | |||||
513 | sub _up_indent { | ||||
514 | my $self = shift; | ||||
515 | my $space = ' ' x $indent_length; | ||||
516 | |||||
517 | my ($pre,$post) = ('',''); | ||||
518 | |||||
519 | $post = "\n" . $space x $indent_count; | ||||
520 | |||||
521 | $indent_count++; | ||||
522 | |||||
523 | $pre = "\n" . $space x $indent_count; | ||||
524 | |||||
525 | return ($pre,$post); | ||||
526 | } | ||||
527 | |||||
528 | |||||
529 | sub _down_indent { $indent_count--; } | ||||
530 | |||||
531 | |||||
532 | sub PP_encode_box { | ||||
533 | { | ||||
534 | depth => $depth, | ||||
535 | indent_count => $indent_count, | ||||
536 | }; | ||||
537 | } | ||||
538 | |||||
539 | } # Convert | ||||
540 | |||||
541 | |||||
542 | sub _encode_ascii { | ||||
543 | join('', | ||||
544 | map { | ||||
545 | $_ <= 127 ? | ||||
546 | chr($_) : | ||||
547 | $_ <= 65535 ? | ||||
548 | sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); | ||||
549 | } unpack('U*', $_[0]) | ||||
550 | ); | ||||
551 | } | ||||
552 | |||||
553 | |||||
554 | sub _encode_latin1 { | ||||
555 | join('', | ||||
556 | map { | ||||
557 | $_ <= 255 ? | ||||
558 | chr($_) : | ||||
559 | $_ <= 65535 ? | ||||
560 | sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); | ||||
561 | } unpack('U*', $_[0]) | ||||
562 | ); | ||||
563 | } | ||||
564 | |||||
565 | |||||
566 | sub _encode_surrogates { # from perlunicode | ||||
567 | my $uni = $_[0] - 0x10000; | ||||
568 | return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); | ||||
569 | } | ||||
570 | |||||
571 | |||||
572 | sub _is_bignum { | ||||
573 | $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); | ||||
574 | } | ||||
575 | |||||
- - | |||||
578 | # | ||||
579 | # JSON => Perl | ||||
580 | # | ||||
581 | |||||
582 | 1 | 200ns | my $max_intsize; | ||
583 | |||||
584 | # spent 286µs within JSON::PP::BEGIN@584 which was called:
# once (286µs+0s) by JSON::BEGIN@1 at line 594 | ||||
585 | 1 | 500ns | my $checkint = 1111; | ||
586 | 1 | 2µs | for my $d (5..64) { | ||
587 | 17 | 5µs | $checkint .= 1; | ||
588 | 17 | 215µs | my $int = eval qq| $checkint |; # spent 2µs executing statements in string eval
# spent 2µs executing statements in string eval
# spent 2µs executing statements in string eval
# spent 2µs executing statements in string eval
# spent 2µs executing statements in string eval
# spent 2µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval
# spent 1µs executing statements in string eval | ||
589 | 17 | 31µs | if ($int =~ /[eE]/) { | ||
590 | 1 | 500ns | $max_intsize = $d - 1; | ||
591 | 1 | 8µs | last; | ||
592 | } | ||||
593 | } | ||||
594 | 1 | 311µs | 1 | 286µs | } # spent 286µs making 1 call to JSON::PP::BEGIN@584 |
595 | |||||
596 | { # PARSE | ||||
597 | |||||
598 | 2 | 4µs | my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> | ||
599 | b => "\x8", | ||||
600 | t => "\x9", | ||||
601 | n => "\xA", | ||||
602 | f => "\xC", | ||||
603 | r => "\xD", | ||||
604 | '\\' => '\\', | ||||
605 | '"' => '"', | ||||
606 | '/' => '/', | ||||
607 | ); | ||||
608 | |||||
609 | 1 | 100ns | my $text; # json data | ||
610 | 1 | 100ns | my $at; # offset | ||
611 | 1 | 0s | my $ch; # 1chracter | ||
612 | 1 | 0s | my $len; # text length (changed according to UTF8 or NON UTF8) | ||
613 | # INTERNAL | ||||
614 | 1 | 0s | my $depth; # nest counter | ||
615 | 1 | 100ns | my $encoding; # json text encoding | ||
616 | 1 | 0s | my $is_valid_utf8; # temp variable | ||
617 | 1 | 100ns | my $utf8_len; # utf8 byte length | ||
618 | # FLAGS | ||||
619 | 1 | 100ns | my $utf8; # must be utf8 | ||
620 | 1 | 100ns | my $max_depth; # max nest nubmer of objects and arrays | ||
621 | 1 | 100ns | my $max_size; | ||
622 | 1 | 100ns | my $relaxed; | ||
623 | 1 | 100ns | my $cb_object; | ||
624 | 1 | 0s | my $cb_sk_object; | ||
625 | |||||
626 | 1 | 0s | my $F_HOOK; | ||
627 | |||||
628 | 1 | 0s | my $allow_bigint; # using Math::BigInt | ||
629 | 1 | 100ns | my $singlequote; # loosely quoting | ||
630 | 1 | 0s | my $loose; # | ||
631 | 1 | 500ns | my $allow_barekey; # bareKey | ||
632 | |||||
633 | # $opt flag | ||||
634 | # 0x00000001 .... decode_prefix | ||||
635 | # 0x10000000 .... incr_parse | ||||
636 | |||||
637 | sub PP_decode_json { | ||||
638 | my ($self, $opt); # $opt is an effective flag during this decode_json. | ||||
639 | |||||
640 | ($self, $text, $opt) = @_; | ||||
641 | |||||
642 | ($at, $ch, $depth) = (0, '', 0); | ||||
643 | |||||
644 | if ( !defined $text or ref $text ) { | ||||
645 | decode_error("malformed JSON string, neither array, object, number, string or atom"); | ||||
646 | } | ||||
647 | |||||
648 | my $idx = $self->{PROPS}; | ||||
649 | |||||
650 | ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) | ||||
651 | = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; | ||||
652 | |||||
653 | if ( $utf8 ) { | ||||
654 | utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); | ||||
655 | } | ||||
656 | else { | ||||
657 | utf8::upgrade( $text ); | ||||
658 | } | ||||
659 | |||||
660 | $len = length $text; | ||||
661 | |||||
662 | ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) | ||||
663 | = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; | ||||
664 | |||||
665 | if ($max_size > 1) { | ||||
666 | 2 | 3.19ms | 2 | 19µs | # spent 16µs (14+3) within JSON::PP::BEGIN@666 which was called:
# once (14µs+3µs) by JSON::BEGIN@1 at line 666 # spent 16µs making 1 call to JSON::PP::BEGIN@666
# spent 3µs making 1 call to bytes::import |
667 | my $bytes = length $text; | ||||
668 | decode_error( | ||||
669 | sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" | ||||
670 | , $bytes, $max_size), 1 | ||||
671 | ) if ($bytes > $max_size); | ||||
672 | } | ||||
673 | |||||
674 | # Currently no effect | ||||
675 | # should use regexp | ||||
676 | my @octets = unpack('C4', $text); | ||||
677 | $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' | ||||
678 | : (!$octets[0] and $octets[1]) ? 'UTF-16BE' | ||||
679 | : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' | ||||
680 | : ( $octets[2] ) ? 'UTF-16LE' | ||||
681 | : (!$octets[2] ) ? 'UTF-32LE' | ||||
682 | : 'unknown'; | ||||
683 | |||||
684 | white(); # remove head white space | ||||
685 | |||||
686 | my $valid_start = defined $ch; # Is there a first character for JSON structure? | ||||
687 | |||||
688 | my $result = value(); | ||||
689 | |||||
690 | return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse | ||||
691 | |||||
692 | decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; | ||||
693 | |||||
694 | if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { | ||||
695 | decode_error( | ||||
696 | 'JSON text must be an object or array (but found number, string, true, false or null,' | ||||
697 | . ' use allow_nonref to allow this)', 1); | ||||
698 | } | ||||
699 | |||||
700 | Carp::croak('something wrong.') if $len < $at; # we won't arrive here. | ||||
701 | |||||
702 | my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length | ||||
703 | |||||
704 | white(); # remove tail white space | ||||
705 | |||||
706 | if ( $ch ) { | ||||
707 | return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix | ||||
708 | decode_error("garbage after JSON object"); | ||||
709 | } | ||||
710 | |||||
711 | ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; | ||||
712 | } | ||||
713 | |||||
714 | |||||
715 | sub next_chr { | ||||
716 | return $ch = undef if($at >= $len); | ||||
717 | $ch = substr($text, $at++, 1); | ||||
718 | } | ||||
719 | |||||
720 | |||||
721 | sub value { | ||||
722 | white(); | ||||
723 | return if(!defined $ch); | ||||
724 | return object() if($ch eq '{'); | ||||
725 | return array() if($ch eq '['); | ||||
726 | return string() if($ch eq '"' or ($singlequote and $ch eq "'")); | ||||
727 | return number() if($ch =~ /[0-9]/ or $ch eq '-'); | ||||
728 | return word(); | ||||
729 | } | ||||
730 | |||||
731 | sub string { | ||||
732 | my ($i, $s, $t, $u); | ||||
733 | my $utf16; | ||||
734 | my $is_utf8; | ||||
735 | |||||
736 | ($is_valid_utf8, $utf8_len) = ('', 0); | ||||
737 | |||||
738 | $s = ''; # basically UTF8 flag on | ||||
739 | |||||
740 | if($ch eq '"' or ($singlequote and $ch eq "'")){ | ||||
741 | my $boundChar = $ch; | ||||
742 | |||||
743 | OUTER: while( defined(next_chr()) ){ | ||||
744 | |||||
745 | if($ch eq $boundChar){ | ||||
746 | next_chr(); | ||||
747 | |||||
748 | if ($utf16) { | ||||
749 | decode_error("missing low surrogate character in surrogate pair"); | ||||
750 | } | ||||
751 | |||||
752 | utf8::decode($s) if($is_utf8); | ||||
753 | |||||
754 | return $s; | ||||
755 | } | ||||
756 | elsif($ch eq '\\'){ | ||||
757 | next_chr(); | ||||
758 | if(exists $escapes{$ch}){ | ||||
759 | $s .= $escapes{$ch}; | ||||
760 | } | ||||
761 | elsif($ch eq 'u'){ # UNICODE handling | ||||
762 | my $u = ''; | ||||
763 | |||||
764 | for(1..4){ | ||||
765 | $ch = next_chr(); | ||||
766 | last OUTER if($ch !~ /[0-9a-fA-F]/); | ||||
767 | $u .= $ch; | ||||
768 | } | ||||
769 | |||||
770 | # U+D800 - U+DBFF | ||||
771 | if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? | ||||
772 | $utf16 = $u; | ||||
773 | } | ||||
774 | # U+DC00 - U+DFFF | ||||
775 | elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? | ||||
776 | unless (defined $utf16) { | ||||
777 | decode_error("missing high surrogate character in surrogate pair"); | ||||
778 | } | ||||
779 | $is_utf8 = 1; | ||||
780 | $s .= JSON_PP_decode_surrogates($utf16, $u) || next; | ||||
781 | $utf16 = undef; | ||||
782 | } | ||||
783 | else { | ||||
784 | if (defined $utf16) { | ||||
785 | decode_error("surrogate pair expected"); | ||||
786 | } | ||||
787 | |||||
788 | if ( ( my $hex = hex( $u ) ) > 127 ) { | ||||
789 | $is_utf8 = 1; | ||||
790 | $s .= JSON_PP_decode_unicode($u) || next; | ||||
791 | } | ||||
792 | else { | ||||
793 | $s .= chr $hex; | ||||
794 | } | ||||
795 | } | ||||
796 | |||||
797 | } | ||||
798 | else{ | ||||
799 | unless ($loose) { | ||||
800 | $at -= 2; | ||||
801 | decode_error('illegal backslash escape sequence in string'); | ||||
802 | } | ||||
803 | $s .= $ch; | ||||
804 | } | ||||
805 | } | ||||
806 | else{ | ||||
807 | |||||
808 | if ( ord $ch > 127 ) { | ||||
809 | if ( $utf8 ) { | ||||
810 | unless( $ch = is_valid_utf8($ch) ) { | ||||
811 | $at -= 1; | ||||
812 | decode_error("malformed UTF-8 character in JSON string"); | ||||
813 | } | ||||
814 | else { | ||||
815 | $at += $utf8_len - 1; | ||||
816 | } | ||||
817 | } | ||||
818 | else { | ||||
819 | utf8::encode( $ch ); | ||||
820 | } | ||||
821 | |||||
822 | $is_utf8 = 1; | ||||
823 | } | ||||
824 | |||||
825 | if (!$loose) { | ||||
826 | if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok | ||||
827 | $at--; | ||||
828 | decode_error('invalid character encountered while parsing JSON string'); | ||||
829 | } | ||||
830 | } | ||||
831 | |||||
832 | $s .= $ch; | ||||
833 | } | ||||
834 | } | ||||
835 | } | ||||
836 | |||||
837 | decode_error("unexpected end of string while parsing JSON string"); | ||||
838 | } | ||||
839 | |||||
840 | |||||
841 | sub white { | ||||
842 | while( defined $ch ){ | ||||
843 | if($ch le ' '){ | ||||
844 | next_chr(); | ||||
845 | } | ||||
846 | elsif($ch eq '/'){ | ||||
847 | next_chr(); | ||||
848 | if(defined $ch and $ch eq '/'){ | ||||
849 | 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); | ||||
850 | } | ||||
851 | elsif(defined $ch and $ch eq '*'){ | ||||
852 | next_chr(); | ||||
853 | while(1){ | ||||
854 | if(defined $ch){ | ||||
855 | if($ch eq '*'){ | ||||
856 | if(defined(next_chr()) and $ch eq '/'){ | ||||
857 | next_chr(); | ||||
858 | last; | ||||
859 | } | ||||
860 | } | ||||
861 | else{ | ||||
862 | next_chr(); | ||||
863 | } | ||||
864 | } | ||||
865 | else{ | ||||
866 | decode_error("Unterminated comment"); | ||||
867 | } | ||||
868 | } | ||||
869 | next; | ||||
870 | } | ||||
871 | else{ | ||||
872 | $at--; | ||||
873 | decode_error("malformed JSON string, neither array, object, number, string or atom"); | ||||
874 | } | ||||
875 | } | ||||
876 | else{ | ||||
877 | if ($relaxed and $ch eq '#') { # correctly? | ||||
878 | pos($text) = $at; | ||||
879 | $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; | ||||
880 | $at = pos($text); | ||||
881 | next_chr; | ||||
882 | next; | ||||
883 | } | ||||
884 | |||||
885 | last; | ||||
886 | } | ||||
887 | } | ||||
888 | } | ||||
889 | |||||
890 | |||||
891 | sub array { | ||||
892 | my $a = $_[0] || []; # you can use this code to use another array ref object. | ||||
893 | |||||
894 | decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') | ||||
895 | if (++$depth > $max_depth); | ||||
896 | |||||
897 | next_chr(); | ||||
898 | white(); | ||||
899 | |||||
900 | if(defined $ch and $ch eq ']'){ | ||||
901 | --$depth; | ||||
902 | next_chr(); | ||||
903 | return $a; | ||||
904 | } | ||||
905 | else { | ||||
906 | while(defined($ch)){ | ||||
907 | push @$a, value(); | ||||
908 | |||||
909 | white(); | ||||
910 | |||||
911 | if (!defined $ch) { | ||||
912 | last; | ||||
913 | } | ||||
914 | |||||
915 | if($ch eq ']'){ | ||||
916 | --$depth; | ||||
917 | next_chr(); | ||||
918 | return $a; | ||||
919 | } | ||||
920 | |||||
921 | if($ch ne ','){ | ||||
922 | last; | ||||
923 | } | ||||
924 | |||||
925 | next_chr(); | ||||
926 | white(); | ||||
927 | |||||
928 | if ($relaxed and $ch eq ']') { | ||||
929 | --$depth; | ||||
930 | next_chr(); | ||||
931 | return $a; | ||||
932 | } | ||||
933 | |||||
934 | } | ||||
935 | } | ||||
936 | |||||
937 | decode_error(", or ] expected while parsing array"); | ||||
938 | } | ||||
939 | |||||
940 | |||||
941 | sub object { | ||||
942 | my $o = $_[0] || {}; # you can use this code to use another hash ref object. | ||||
943 | my $k; | ||||
944 | |||||
945 | decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') | ||||
946 | if (++$depth > $max_depth); | ||||
947 | next_chr(); | ||||
948 | white(); | ||||
949 | |||||
950 | if(defined $ch and $ch eq '}'){ | ||||
951 | --$depth; | ||||
952 | next_chr(); | ||||
953 | if ($F_HOOK) { | ||||
954 | return _json_object_hook($o); | ||||
955 | } | ||||
956 | return $o; | ||||
957 | } | ||||
958 | else { | ||||
959 | while (defined $ch) { | ||||
960 | $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); | ||||
961 | white(); | ||||
962 | |||||
963 | if(!defined $ch or $ch ne ':'){ | ||||
964 | $at--; | ||||
965 | decode_error("':' expected"); | ||||
966 | } | ||||
967 | |||||
968 | next_chr(); | ||||
969 | $o->{$k} = value(); | ||||
970 | white(); | ||||
971 | |||||
972 | last if (!defined $ch); | ||||
973 | |||||
974 | if($ch eq '}'){ | ||||
975 | --$depth; | ||||
976 | next_chr(); | ||||
977 | if ($F_HOOK) { | ||||
978 | return _json_object_hook($o); | ||||
979 | } | ||||
980 | return $o; | ||||
981 | } | ||||
982 | |||||
983 | if($ch ne ','){ | ||||
984 | last; | ||||
985 | } | ||||
986 | |||||
987 | next_chr(); | ||||
988 | white(); | ||||
989 | |||||
990 | if ($relaxed and $ch eq '}') { | ||||
991 | --$depth; | ||||
992 | next_chr(); | ||||
993 | if ($F_HOOK) { | ||||
994 | return _json_object_hook($o); | ||||
995 | } | ||||
996 | return $o; | ||||
997 | } | ||||
998 | |||||
999 | } | ||||
1000 | |||||
1001 | } | ||||
1002 | |||||
1003 | $at--; | ||||
1004 | decode_error(", or } expected while parsing object/hash"); | ||||
1005 | } | ||||
1006 | |||||
1007 | |||||
1008 | sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition | ||||
1009 | my $key; | ||||
1010 | while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ | ||||
1011 | $key .= $ch; | ||||
1012 | next_chr(); | ||||
1013 | } | ||||
1014 | return $key; | ||||
1015 | } | ||||
1016 | |||||
1017 | |||||
1018 | sub word { | ||||
1019 | my $word = substr($text,$at-1,4); | ||||
1020 | |||||
1021 | if($word eq 'true'){ | ||||
1022 | $at += 3; | ||||
1023 | next_chr; | ||||
1024 | return $JSON::PP::true; | ||||
1025 | } | ||||
1026 | elsif($word eq 'null'){ | ||||
1027 | $at += 3; | ||||
1028 | next_chr; | ||||
1029 | return undef; | ||||
1030 | } | ||||
1031 | elsif($word eq 'fals'){ | ||||
1032 | $at += 3; | ||||
1033 | if(substr($text,$at,1) eq 'e'){ | ||||
1034 | $at++; | ||||
1035 | next_chr; | ||||
1036 | return $JSON::PP::false; | ||||
1037 | } | ||||
1038 | } | ||||
1039 | |||||
1040 | $at--; # for decode_error report | ||||
1041 | |||||
1042 | decode_error("'null' expected") if ($word =~ /^n/); | ||||
1043 | decode_error("'true' expected") if ($word =~ /^t/); | ||||
1044 | decode_error("'false' expected") if ($word =~ /^f/); | ||||
1045 | decode_error("malformed JSON string, neither array, object, number, string or atom"); | ||||
1046 | } | ||||
1047 | |||||
1048 | |||||
1049 | sub number { | ||||
1050 | my $n = ''; | ||||
1051 | my $v; | ||||
1052 | |||||
1053 | # According to RFC4627, hex or oct digts are invalid. | ||||
1054 | if($ch eq '0'){ | ||||
1055 | my $peek = substr($text,$at,1); | ||||
1056 | my $hex = $peek =~ /[xX]/; # 0 or 1 | ||||
1057 | |||||
1058 | if($hex){ | ||||
1059 | decode_error("malformed number (leading zero must not be followed by another digit)"); | ||||
1060 | ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); | ||||
1061 | } | ||||
1062 | else{ # oct | ||||
1063 | ($n) = ( substr($text, $at) =~ /^([0-7]+)/); | ||||
1064 | if (defined $n and length $n > 1) { | ||||
1065 | decode_error("malformed number (leading zero must not be followed by another digit)"); | ||||
1066 | } | ||||
1067 | } | ||||
1068 | |||||
1069 | if(defined $n and length($n)){ | ||||
1070 | if (!$hex and length($n) == 1) { | ||||
1071 | decode_error("malformed number (leading zero must not be followed by another digit)"); | ||||
1072 | } | ||||
1073 | $at += length($n) + $hex; | ||||
1074 | next_chr; | ||||
1075 | return $hex ? hex($n) : oct($n); | ||||
1076 | } | ||||
1077 | } | ||||
1078 | |||||
1079 | if($ch eq '-'){ | ||||
1080 | $n = '-'; | ||||
1081 | next_chr; | ||||
1082 | if (!defined $ch or $ch !~ /\d/) { | ||||
1083 | decode_error("malformed number (no digits after initial minus)"); | ||||
1084 | } | ||||
1085 | } | ||||
1086 | |||||
1087 | while(defined $ch and $ch =~ /\d/){ | ||||
1088 | $n .= $ch; | ||||
1089 | next_chr; | ||||
1090 | } | ||||
1091 | |||||
1092 | if(defined $ch and $ch eq '.'){ | ||||
1093 | $n .= '.'; | ||||
1094 | |||||
1095 | next_chr; | ||||
1096 | if (!defined $ch or $ch !~ /\d/) { | ||||
1097 | decode_error("malformed number (no digits after decimal point)"); | ||||
1098 | } | ||||
1099 | else { | ||||
1100 | $n .= $ch; | ||||
1101 | } | ||||
1102 | |||||
1103 | while(defined(next_chr) and $ch =~ /\d/){ | ||||
1104 | $n .= $ch; | ||||
1105 | } | ||||
1106 | } | ||||
1107 | |||||
1108 | if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ | ||||
1109 | $n .= $ch; | ||||
1110 | next_chr; | ||||
1111 | |||||
1112 | if(defined($ch) and ($ch eq '+' or $ch eq '-')){ | ||||
1113 | $n .= $ch; | ||||
1114 | next_chr; | ||||
1115 | if (!defined $ch or $ch =~ /\D/) { | ||||
1116 | decode_error("malformed number (no digits after exp sign)"); | ||||
1117 | } | ||||
1118 | $n .= $ch; | ||||
1119 | } | ||||
1120 | elsif(defined($ch) and $ch =~ /\d/){ | ||||
1121 | $n .= $ch; | ||||
1122 | } | ||||
1123 | else { | ||||
1124 | decode_error("malformed number (no digits after exp sign)"); | ||||
1125 | } | ||||
1126 | |||||
1127 | while(defined(next_chr) and $ch =~ /\d/){ | ||||
1128 | $n .= $ch; | ||||
1129 | } | ||||
1130 | |||||
1131 | } | ||||
1132 | |||||
1133 | $v .= $n; | ||||
1134 | |||||
1135 | if ($v !~ /[.eE]/ and length $v > $max_intsize) { | ||||
1136 | if ($allow_bigint) { # from Adam Sussman | ||||
1137 | require Math::BigInt; | ||||
1138 | return Math::BigInt->new($v); | ||||
1139 | } | ||||
1140 | else { | ||||
1141 | return "$v"; | ||||
1142 | } | ||||
1143 | } | ||||
1144 | elsif ($allow_bigint) { | ||||
1145 | require Math::BigFloat; | ||||
1146 | return Math::BigFloat->new($v); | ||||
1147 | } | ||||
1148 | |||||
1149 | return 0+$v; | ||||
1150 | } | ||||
1151 | |||||
1152 | |||||
1153 | sub is_valid_utf8 { | ||||
1154 | |||||
1155 | $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 | ||||
1156 | : $_[0] =~ /[\xC2-\xDF]/ ? 2 | ||||
1157 | : $_[0] =~ /[\xE0-\xEF]/ ? 3 | ||||
1158 | : $_[0] =~ /[\xF0-\xF4]/ ? 4 | ||||
1159 | : 0 | ||||
1160 | ; | ||||
1161 | |||||
1162 | return unless $utf8_len; | ||||
1163 | |||||
1164 | my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); | ||||
1165 | |||||
1166 | return ( $is_valid_utf8 =~ /^(?: | ||||
1167 | [\x00-\x7F] | ||||
1168 | |[\xC2-\xDF][\x80-\xBF] | ||||
1169 | |[\xE0][\xA0-\xBF][\x80-\xBF] | ||||
1170 | |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] | ||||
1171 | |[\xED][\x80-\x9F][\x80-\xBF] | ||||
1172 | |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] | ||||
1173 | |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] | ||||
1174 | |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] | ||||
1175 | |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] | ||||
1176 | )$/x ) ? $is_valid_utf8 : ''; | ||||
1177 | } | ||||
1178 | |||||
1179 | |||||
1180 | sub decode_error { | ||||
1181 | my $error = shift; | ||||
1182 | my $no_rep = shift; | ||||
1183 | my $str = defined $text ? substr($text, $at) : ''; | ||||
1184 | my $mess = ''; | ||||
1185 | my $type = $] >= 5.008 ? 'U*' | ||||
1186 | : $] < 5.006 ? 'C*' | ||||
1187 | : utf8::is_utf8( $str ) ? 'U*' # 5.6 | ||||
1188 | : 'C*' | ||||
1189 | ; | ||||
1190 | |||||
1191 | for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? | ||||
1192 | $mess .= $c == 0x07 ? '\a' | ||||
1193 | : $c == 0x09 ? '\t' | ||||
1194 | : $c == 0x0a ? '\n' | ||||
1195 | : $c == 0x0d ? '\r' | ||||
1196 | : $c == 0x0c ? '\f' | ||||
1197 | : $c < 0x20 ? sprintf('\x{%x}', $c) | ||||
1198 | : $c == 0x5c ? '\\\\' | ||||
1199 | : $c < 0x80 ? chr($c) | ||||
1200 | : sprintf('\x{%x}', $c) | ||||
1201 | ; | ||||
1202 | if ( length $mess >= 20 ) { | ||||
1203 | $mess .= '...'; | ||||
1204 | last; | ||||
1205 | } | ||||
1206 | } | ||||
1207 | |||||
1208 | unless ( length $mess ) { | ||||
1209 | $mess = '(end of string)'; | ||||
1210 | } | ||||
1211 | |||||
1212 | Carp::croak ( | ||||
1213 | $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" | ||||
1214 | ); | ||||
1215 | |||||
1216 | } | ||||
1217 | |||||
1218 | |||||
1219 | sub _json_object_hook { | ||||
1220 | my $o = $_[0]; | ||||
1221 | my @ks = keys %{$o}; | ||||
1222 | |||||
1223 | if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { | ||||
1224 | my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); | ||||
1225 | if (@val == 1) { | ||||
1226 | return $val[0]; | ||||
1227 | } | ||||
1228 | } | ||||
1229 | |||||
1230 | my @val = $cb_object->($o) if ($cb_object); | ||||
1231 | if (@val == 0 or @val > 1) { | ||||
1232 | return $o; | ||||
1233 | } | ||||
1234 | else { | ||||
1235 | return $val[0]; | ||||
1236 | } | ||||
1237 | } | ||||
1238 | |||||
1239 | |||||
1240 | sub PP_decode_box { | ||||
1241 | { | ||||
1242 | text => $text, | ||||
1243 | at => $at, | ||||
1244 | ch => $ch, | ||||
1245 | len => $len, | ||||
1246 | depth => $depth, | ||||
1247 | encoding => $encoding, | ||||
1248 | is_valid_utf8 => $is_valid_utf8, | ||||
1249 | }; | ||||
1250 | } | ||||
1251 | |||||
1252 | } # PARSE | ||||
1253 | |||||
1254 | |||||
1255 | sub _decode_surrogates { # from perlunicode | ||||
1256 | my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); | ||||
1257 | my $un = pack('U*', $uni); | ||||
1258 | utf8::encode( $un ); | ||||
1259 | return $un; | ||||
1260 | } | ||||
1261 | |||||
1262 | |||||
1263 | sub _decode_unicode { | ||||
1264 | my $un = pack('U', hex shift); | ||||
1265 | utf8::encode( $un ); | ||||
1266 | return $un; | ||||
1267 | } | ||||
1268 | |||||
1269 | # | ||||
1270 | # Setup for various Perl versions (the code from JSON::PP58) | ||||
1271 | # | ||||
1272 | |||||
1273 | # spent 85µs within JSON::PP::BEGIN@1273 which was called:
# once (85µs+0s) by JSON::BEGIN@1 at line 1329 | ||||
1274 | |||||
1275 | 1 | 700ns | unless ( defined &utf8::is_utf8 ) { | ||
1276 | require Encode; | ||||
1277 | *utf8::is_utf8 = *Encode::is_utf8; | ||||
1278 | } | ||||
1279 | |||||
1280 | 1 | 1µs | if ( $] >= 5.008 ) { | ||
1281 | 1 | 2µs | *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; | ||
1282 | 1 | 400ns | *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; | ||
1283 | 1 | 400ns | *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; | ||
1284 | 1 | 700ns | *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; | ||
1285 | } | ||||
1286 | |||||
1287 | 1 | 500ns | if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. | ||
1288 | package JSON::PP; | ||||
1289 | require subs; | ||||
1290 | subs->import('join'); | ||||
1291 | eval q| | ||||
1292 | sub join { | ||||
1293 | return '' if (@_ < 2); | ||||
1294 | my $j = shift; | ||||
1295 | my $str = shift; | ||||
1296 | for (@_) { $str .= $j . $_; } | ||||
1297 | return $str; | ||||
1298 | } | ||||
1299 | |; | ||||
1300 | } | ||||
1301 | |||||
1302 | |||||
1303 | sub JSON::PP::incr_parse { | ||||
1304 | local $Carp::CarpLevel = 1; | ||||
1305 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); | ||||
1306 | } | ||||
1307 | |||||
1308 | |||||
1309 | sub JSON::PP::incr_skip { | ||||
1310 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; | ||||
1311 | } | ||||
1312 | |||||
1313 | |||||
1314 | sub JSON::PP::incr_reset { | ||||
1315 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; | ||||
1316 | } | ||||
1317 | |||||
1318 | 1 | 81µs | eval q{ | ||
1319 | sub JSON::PP::incr_text : lvalue { | ||||
1320 | $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; | ||||
1321 | |||||
1322 | if ( $_[0]->{_incr_parser}->{incr_parsing} ) { | ||||
1323 | Carp::croak("incr_text can not be called when the incremental parser already started parsing"); | ||||
1324 | } | ||||
1325 | $_[0]->{_incr_parser}->{incr_text}; | ||||
1326 | } | ||||
1327 | } if ( $] >= 5.006 ); | ||||
1328 | |||||
1329 | 1 | 314µs | 1 | 85µs | } # Setup for various Perl versions (the code from JSON::PP58) # spent 85µs making 1 call to JSON::PP::BEGIN@1273 |
1330 | |||||
1331 | |||||
1332 | ############################### | ||||
1333 | # Utilities | ||||
1334 | # | ||||
1335 | |||||
1336 | # spent 32µs within JSON::PP::BEGIN@1336 which was called:
# once (32µs+0s) by JSON::BEGIN@1 at line 1389 | ||||
1337 | 1 | 21µs | eval 'require Scalar::Util'; # spent 3µs executing statements in string eval | ||
1338 | 1 | 7µs | unless($@){ | ||
1339 | 1 | 2µs | *JSON::PP::blessed = \&Scalar::Util::blessed; | ||
1340 | 1 | 600ns | *JSON::PP::reftype = \&Scalar::Util::reftype; | ||
1341 | 1 | 700ns | *JSON::PP::refaddr = \&Scalar::Util::refaddr; | ||
1342 | } | ||||
1343 | else{ # This code is from Sclar::Util. | ||||
1344 | # warn $@; | ||||
1345 | eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; | ||||
1346 | *JSON::PP::blessed = sub { | ||||
1347 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); | ||||
1348 | ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; | ||||
1349 | }; | ||||
1350 | my %tmap = qw( | ||||
1351 | B::NULL SCALAR | ||||
1352 | B::HV HASH | ||||
1353 | B::AV ARRAY | ||||
1354 | B::CV CODE | ||||
1355 | B::IO IO | ||||
1356 | B::GV GLOB | ||||
1357 | B::REGEXP REGEXP | ||||
1358 | ); | ||||
1359 | *JSON::PP::reftype = sub { | ||||
1360 | my $r = shift; | ||||
1361 | |||||
1362 | return undef unless length(ref($r)); | ||||
1363 | |||||
1364 | my $t = ref(B::svref_2object($r)); | ||||
1365 | |||||
1366 | return | ||||
1367 | exists $tmap{$t} ? $tmap{$t} | ||||
1368 | : length(ref($$r)) ? 'REF' | ||||
1369 | : 'SCALAR'; | ||||
1370 | }; | ||||
1371 | *JSON::PP::refaddr = sub { | ||||
1372 | return undef unless length(ref($_[0])); | ||||
1373 | |||||
1374 | my $addr; | ||||
1375 | if(defined(my $pkg = blessed($_[0]))) { | ||||
1376 | $addr .= bless $_[0], 'Scalar::Util::Fake'; | ||||
1377 | bless $_[0], $pkg; | ||||
1378 | } | ||||
1379 | else { | ||||
1380 | $addr .= $_[0] | ||||
1381 | } | ||||
1382 | |||||
1383 | $addr =~ /0x(\w+)/; | ||||
1384 | local $^W; | ||||
1385 | #no warnings 'portable'; | ||||
1386 | hex($1); | ||||
1387 | } | ||||
1388 | } | ||||
1389 | 1 | 219µs | 1 | 32µs | } # spent 32µs making 1 call to JSON::PP::BEGIN@1336 |
1390 | |||||
1391 | |||||
1392 | # shamely copied and modified from JSON::XS code. | ||||
1393 | |||||
1394 | 1 | 29µs | $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; | ||
1395 | 1 | 1µs | $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; | ||
1396 | |||||
1397 | sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } | ||||
1398 | |||||
1399 | sub true { $JSON::PP::true } | ||||
1400 | sub false { $JSON::PP::false } | ||||
1401 | sub null { undef; } | ||||
1402 | |||||
1403 | ############################### | ||||
1404 | |||||
1405 | package JSON::PP::Boolean; | ||||
1406 | |||||
1407 | # spent 60µs (20+40) within JSON::PP::Boolean::BEGIN@1407 which was called:
# once (20µs+40µs) by JSON::BEGIN@1 at line 1412 | ||||
1408 | "0+" => sub { ${$_[0]} }, | ||||
1409 | "++" => sub { $_[0] = ${$_[0]} + 1 }, | ||||
1410 | "--" => sub { $_[0] = ${$_[0]} - 1 }, | ||||
1411 | 1 | 16µs | 1 | 40µs | fallback => 1, # spent 40µs making 1 call to overload::import |
1412 | 1 | 35µs | 1 | 60µs | ); # spent 60µs making 1 call to JSON::PP::Boolean::BEGIN@1407 |
1413 | |||||
1414 | |||||
1415 | ############################### | ||||
1416 | |||||
1417 | package JSON::PP::IncrParser; | ||||
1418 | |||||
1419 | 2 | 34µs | 2 | 40µs | # spent 25µs (10+15) within JSON::PP::IncrParser::BEGIN@1419 which was called:
# once (10µs+15µs) by JSON::BEGIN@1 at line 1419 # spent 25µs making 1 call to JSON::PP::IncrParser::BEGIN@1419
# spent 15µs making 1 call to strict::import |
1420 | |||||
1421 | 2 | 35µs | 2 | 79µs | # spent 44µs (9+35) within JSON::PP::IncrParser::BEGIN@1421 which was called:
# once (9µs+35µs) by JSON::BEGIN@1 at line 1421 # spent 44µs making 1 call to JSON::PP::IncrParser::BEGIN@1421
# spent 35µs making 1 call to constant::import |
1422 | 2 | 33µs | 2 | 81µs | # spent 46µs (10+36) within JSON::PP::IncrParser::BEGIN@1422 which was called:
# once (10µs+36µs) by JSON::BEGIN@1 at line 1422 # spent 46µs making 1 call to JSON::PP::IncrParser::BEGIN@1422
# spent 36µs making 1 call to constant::import |
1423 | 2 | 32µs | 2 | 70µs | # spent 39µs (9+30) within JSON::PP::IncrParser::BEGIN@1423 which was called:
# once (9µs+30µs) by JSON::BEGIN@1 at line 1423 # spent 39µs making 1 call to JSON::PP::IncrParser::BEGIN@1423
# spent 30µs making 1 call to constant::import |
1424 | 2 | 30µs | 2 | 65µs | # spent 37µs (9+28) within JSON::PP::IncrParser::BEGIN@1424 which was called:
# once (9µs+28µs) by JSON::BEGIN@1 at line 1424 # spent 37µs making 1 call to JSON::PP::IncrParser::BEGIN@1424
# spent 28µs making 1 call to constant::import |
1425 | 2 | 31µs | 2 | 79µs | # spent 44µs (9+35) within JSON::PP::IncrParser::BEGIN@1425 which was called:
# once (9µs+35µs) by JSON::BEGIN@1 at line 1425 # spent 44µs making 1 call to JSON::PP::IncrParser::BEGIN@1425
# spent 35µs making 1 call to constant::import |
1426 | 2 | 952µs | 2 | 81µs | # spent 45µs (10+35) within JSON::PP::IncrParser::BEGIN@1426 which was called:
# once (10µs+35µs) by JSON::BEGIN@1 at line 1426 # spent 45µs making 1 call to JSON::PP::IncrParser::BEGIN@1426
# spent 35µs making 1 call to constant::import |
1427 | |||||
1428 | 1 | 300ns | $JSON::PP::IncrParser::VERSION = '1.01'; | ||
1429 | |||||
1430 | 1 | 1µs | my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; | ||
1431 | |||||
1432 | sub new { | ||||
1433 | my ( $class ) = @_; | ||||
1434 | |||||
1435 | bless { | ||||
1436 | incr_nest => 0, | ||||
1437 | incr_text => undef, | ||||
1438 | incr_parsing => 0, | ||||
1439 | incr_p => 0, | ||||
1440 | }, $class; | ||||
1441 | } | ||||
1442 | |||||
1443 | |||||
1444 | sub incr_parse { | ||||
1445 | my ( $self, $coder, $text ) = @_; | ||||
1446 | |||||
1447 | $self->{incr_text} = '' unless ( defined $self->{incr_text} ); | ||||
1448 | |||||
1449 | if ( defined $text ) { | ||||
1450 | if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { | ||||
1451 | utf8::upgrade( $self->{incr_text} ) ; | ||||
1452 | utf8::decode( $self->{incr_text} ) ; | ||||
1453 | } | ||||
1454 | $self->{incr_text} .= $text; | ||||
1455 | } | ||||
1456 | |||||
1457 | |||||
1458 | my $max_size = $coder->get_max_size; | ||||
1459 | |||||
1460 | if ( defined wantarray ) { | ||||
1461 | |||||
1462 | $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode}; | ||||
1463 | |||||
1464 | if ( wantarray ) { | ||||
1465 | my @ret; | ||||
1466 | |||||
1467 | $self->{incr_parsing} = 1; | ||||
1468 | |||||
1469 | do { | ||||
1470 | push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); | ||||
1471 | |||||
1472 | unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { | ||||
1473 | $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR; | ||||
1474 | } | ||||
1475 | |||||
1476 | } until ( length $self->{incr_text} >= $self->{incr_p} ); | ||||
1477 | |||||
1478 | $self->{incr_parsing} = 0; | ||||
1479 | |||||
1480 | return @ret; | ||||
1481 | } | ||||
1482 | else { # in scalar context | ||||
1483 | $self->{incr_parsing} = 1; | ||||
1484 | my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); | ||||
1485 | $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans | ||||
1486 | return $obj ? $obj : undef; # $obj is an empty string, parsing was completed. | ||||
1487 | } | ||||
1488 | |||||
1489 | } | ||||
1490 | |||||
1491 | } | ||||
1492 | |||||
1493 | |||||
1494 | sub _incr_parse { | ||||
1495 | my ( $self, $coder, $text, $skip ) = @_; | ||||
1496 | my $p = $self->{incr_p}; | ||||
1497 | my $restore = $p; | ||||
1498 | |||||
1499 | my @obj; | ||||
1500 | my $len = length $text; | ||||
1501 | |||||
1502 | if ( $self->{incr_mode} == INCR_M_WS ) { | ||||
1503 | while ( $len > $p ) { | ||||
1504 | my $s = substr( $text, $p, 1 ); | ||||
1505 | $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); | ||||
1506 | $self->{incr_mode} = INCR_M_JSON; | ||||
1507 | last; | ||||
1508 | } | ||||
1509 | } | ||||
1510 | |||||
1511 | while ( $len > $p ) { | ||||
1512 | my $s = substr( $text, $p++, 1 ); | ||||
1513 | |||||
1514 | if ( $s eq '"' ) { | ||||
1515 | if (substr( $text, $p - 2, 1 ) eq '\\' ) { | ||||
1516 | next; | ||||
1517 | } | ||||
1518 | |||||
1519 | if ( $self->{incr_mode} != INCR_M_STR ) { | ||||
1520 | $self->{incr_mode} = INCR_M_STR; | ||||
1521 | } | ||||
1522 | else { | ||||
1523 | $self->{incr_mode} = INCR_M_JSON; | ||||
1524 | unless ( $self->{incr_nest} ) { | ||||
1525 | last; | ||||
1526 | } | ||||
1527 | } | ||||
1528 | } | ||||
1529 | |||||
1530 | if ( $self->{incr_mode} == INCR_M_JSON ) { | ||||
1531 | |||||
1532 | if ( $s eq '[' or $s eq '{' ) { | ||||
1533 | if ( ++$self->{incr_nest} > $coder->get_max_depth ) { | ||||
1534 | Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); | ||||
1535 | } | ||||
1536 | } | ||||
1537 | elsif ( $s eq ']' or $s eq '}' ) { | ||||
1538 | last if ( --$self->{incr_nest} <= 0 ); | ||||
1539 | } | ||||
1540 | elsif ( $s eq '#' ) { | ||||
1541 | while ( $len > $p ) { | ||||
1542 | last if substr( $text, $p++, 1 ) eq "\n"; | ||||
1543 | } | ||||
1544 | } | ||||
1545 | |||||
1546 | } | ||||
1547 | |||||
1548 | } | ||||
1549 | |||||
1550 | $self->{incr_p} = $p; | ||||
1551 | |||||
1552 | return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} ); | ||||
1553 | return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); | ||||
1554 | |||||
1555 | return '' unless ( length substr( $self->{incr_text}, 0, $p ) ); | ||||
1556 | |||||
1557 | local $Carp::CarpLevel = 2; | ||||
1558 | |||||
1559 | $self->{incr_p} = $restore; | ||||
1560 | $self->{incr_c} = $p; | ||||
1561 | |||||
1562 | my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 ); | ||||
1563 | |||||
1564 | $self->{incr_text} = substr( $self->{incr_text}, $p ); | ||||
1565 | $self->{incr_p} = 0; | ||||
1566 | |||||
1567 | return $obj or ''; | ||||
1568 | } | ||||
1569 | |||||
1570 | |||||
1571 | sub incr_text { | ||||
1572 | if ( $_[0]->{incr_parsing} ) { | ||||
1573 | Carp::croak("incr_text can not be called when the incremental parser already started parsing"); | ||||
1574 | } | ||||
1575 | $_[0]->{incr_text}; | ||||
1576 | } | ||||
1577 | |||||
1578 | |||||
1579 | sub incr_skip { | ||||
1580 | my $self = shift; | ||||
1581 | $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); | ||||
1582 | $self->{incr_p} = 0; | ||||
1583 | } | ||||
1584 | |||||
1585 | |||||
1586 | sub incr_reset { | ||||
1587 | my $self = shift; | ||||
1588 | $self->{incr_text} = undef; | ||||
1589 | $self->{incr_p} = 0; | ||||
1590 | $self->{incr_mode} = 0; | ||||
1591 | $self->{incr_nest} = 0; | ||||
1592 | $self->{incr_parsing} = 0; | ||||
1593 | } | ||||
1594 | |||||
1595 | ############################### | ||||
1596 | |||||
1597 | |||||
1598 | 1 | 22µs | 1; | ||
1599 | __END__ |