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