← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:11:23 2013

Filename/usr/share/perl5/JSON/PP.pm
StatementsExecuted 412 statements in 11.3ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.42ms3.78msJSON::PP::::BEGIN@11 JSON::PP::BEGIN@11
1112.34ms2.43msJSON::PP::::BEGIN@43 JSON::PP::BEGIN@43
111363µs400µsJSON::PP::::BEGIN@614 JSON::PP::BEGIN@614
111109µs109µsJSON::PP::::BEGIN@5 JSON::PP::BEGIN@5
11172µs72µsJSON::PP::::new JSON::PP::new
11163µs290µsJSON::PP::::hash_to_json JSON::PP::hash_to_json
62160µs79µsJSON::PP::::string_to_json JSON::PP::string_to_json
41155µs158µsJSON::PP::::value_to_json JSON::PP::value_to_json
63147µs330µsJSON::PP::::object_to_json JSON::PP::object_to_json (recurses: max depth 2, inclusive time 484µs)
171138µs38µsJSON::PP::::CORE:match JSON::PP::CORE:match (opcode)
11134µs34µsJSON::PP::::BEGIN@1307 JSON::PP::BEGIN@1307
11128µs466µsJSON::PP::::encode_json JSON::PP::encode_json
11124µs31µsJSON::PP::::BEGIN@696 JSON::PP::BEGIN@696
11121µs352µsJSON::PP::::PP_encode_json JSON::PP::PP_encode_json
11118µs81µsJSON::PP::Boolean::::BEGIN@1339 JSON::PP::Boolean::BEGIN@1339
11117µs320µsJSON::PP::::array_to_json JSON::PP::array_to_json
11116µs79µsJSON::PP::::BEGIN@21 JSON::PP::BEGIN@21
11114µs53µsJSON::PP::::BEGIN@37 JSON::PP::BEGIN@37
11114µs89µsJSON::PP::::BEGIN@7 JSON::PP::BEGIN@7
11113µs18µsJSON::PP::IncrParser::::BEGIN@1351JSON::PP::IncrParser::BEGIN@1351
11113µs49µsJSON::PP::::BEGIN@36 JSON::PP::BEGIN@36
11112µs17µsJSON::PP::::BEGIN@6 JSON::PP::BEGIN@6
11112µs58µsJSON::PP::::BEGIN@28 JSON::PP::BEGIN@28
11112µs51µsJSON::PP::::BEGIN@39 JSON::PP::BEGIN@39
11112µs81µsJSON::PP::IncrParser::::BEGIN@1353JSON::PP::IncrParser::BEGIN@1353
11110µs49µsJSON::PP::::BEGIN@41 JSON::PP::BEGIN@41
11110µs42µsJSON::PP::::BEGIN@31 JSON::PP::BEGIN@31
11110µs40µsJSON::PP::::BEGIN@27 JSON::PP::BEGIN@27
11110µs44µsJSON::PP::::BEGIN@22 JSON::PP::BEGIN@22
1119µs42µsJSON::PP::::BEGIN@38 JSON::PP::BEGIN@38
1119µs43µsJSON::PP::::BEGIN@34 JSON::PP::BEGIN@34
1119µs43µsJSON::PP::::BEGIN@29 JSON::PP::BEGIN@29
1119µs42µsJSON::PP::IncrParser::::BEGIN@1356JSON::PP::IncrParser::BEGIN@1356
1119µs30µsJSON::PP::::BEGIN@8 JSON::PP::BEGIN@8
1119µs41µsJSON::PP::::BEGIN@30 JSON::PP::BEGIN@30
12219µs9µsJSON::PP::::CORE:subst JSON::PP::CORE:subst (opcode)
1118µs39µsJSON::PP::::BEGIN@25 JSON::PP::BEGIN@25
1118µs40µsJSON::PP::::BEGIN@23 JSON::PP::BEGIN@23
1118µs40µsJSON::PP::IncrParser::::BEGIN@1355JSON::PP::IncrParser::BEGIN@1355
1118µs40µsJSON::PP::::BEGIN@26 JSON::PP::BEGIN@26
1118µs39µsJSON::PP::IncrParser::::BEGIN@1358JSON::PP::IncrParser::BEGIN@1358
1118µs42µsJSON::PP::IncrParser::::BEGIN@1354JSON::PP::IncrParser::BEGIN@1354
1118µs40µsJSON::PP::::BEGIN@32 JSON::PP::BEGIN@32
1118µs40µsJSON::PP::::BEGIN@24 JSON::PP::BEGIN@24
1118µs39µsJSON::PP::IncrParser::::BEGIN@1357JSON::PP::IncrParser::BEGIN@1357
1118µs39µsJSON::PP::::BEGIN@35 JSON::PP::BEGIN@35
1117µs359µsJSON::PP::::encode JSON::PP::encode
1115µs5µsJSON::PP::::BEGIN@10 JSON::PP::BEGIN@10
1115µs5µsJSON::PP::::_sort JSON::PP::_sort
0000s0sJSON::PP::Boolean::::__ANON__[:1340] JSON::PP::Boolean::__ANON__[:1340]
0000s0sJSON::PP::Boolean::::__ANON__[:1341] JSON::PP::Boolean::__ANON__[:1341]
0000s0sJSON::PP::Boolean::::__ANON__[:1342] JSON::PP::Boolean::__ANON__[:1342]
0000s0sJSON::PP::IncrParser::::_incr_parseJSON::PP::IncrParser::_incr_parse
0000s0sJSON::PP::IncrParser::::incr_parseJSON::PP::IncrParser::incr_parse
0000s0sJSON::PP::IncrParser::::incr_resetJSON::PP::IncrParser::incr_reset
0000s0sJSON::PP::IncrParser::::incr_skipJSON::PP::IncrParser::incr_skip
0000s0sJSON::PP::IncrParser::::incr_textJSON::PP::IncrParser::incr_text
0000s0sJSON::PP::IncrParser::::newJSON::PP::IncrParser::new
0000s0sJSON::PP::::PP_decode_box JSON::PP::PP_decode_box
0000s0sJSON::PP::::PP_decode_json JSON::PP::PP_decode_json
0000s0sJSON::PP::::PP_encode_box JSON::PP::PP_encode_box
0000s0sJSON::PP::::__ANON__[:1318] JSON::PP::__ANON__[:1318]
0000s0sJSON::PP::::__ANON__[:135] JSON::PP::__ANON__[:135]
0000s0sJSON::PP::::__ANON__[:282] JSON::PP::__ANON__[:282]
0000s0sJSON::PP::::__ANON__[:287] JSON::PP::__ANON__[:287]
0000s0sJSON::PP::::_decode_surrogates JSON::PP::_decode_surrogates
0000s0sJSON::PP::::_decode_unicode JSON::PP::_decode_unicode
0000s0sJSON::PP::::_down_indent JSON::PP::_down_indent
0000s0sJSON::PP::::_encode_ascii JSON::PP::_encode_ascii
0000s0sJSON::PP::::_encode_latin1 JSON::PP::_encode_latin1
0000s0sJSON::PP::::_encode_surrogates JSON::PP::_encode_surrogates
0000s0sJSON::PP::::_is_bignum JSON::PP::_is_bignum
0000s0sJSON::PP::::_json_object_hook JSON::PP::_json_object_hook
0000s0sJSON::PP::::_up_indent JSON::PP::_up_indent
0000s0sJSON::PP::::allow_bigint JSON::PP::allow_bigint
0000s0sJSON::PP::::array JSON::PP::array
0000s0sJSON::PP::::bareKey JSON::PP::bareKey
0000s0sJSON::PP::::blessed_to_json JSON::PP::blessed_to_json
0000s0sJSON::PP::::decode JSON::PP::decode
0000s0sJSON::PP::::decode_error JSON::PP::decode_error
0000s0sJSON::PP::::decode_json JSON::PP::decode_json
0000s0sJSON::PP::::decode_prefix JSON::PP::decode_prefix
0000s0sJSON::PP::::encode_error JSON::PP::encode_error
0000s0sJSON::PP::::false JSON::PP::false
0000s0sJSON::PP::::filter_json_object JSON::PP::filter_json_object
0000s0sJSON::PP::::filter_json_single_key_object JSON::PP::filter_json_single_key_object
0000s0sJSON::PP::::from_json JSON::PP::from_json
0000s0sJSON::PP::::get_indent_length JSON::PP::get_indent_length
0000s0sJSON::PP::::get_max_depth JSON::PP::get_max_depth
0000s0sJSON::PP::::get_max_size JSON::PP::get_max_size
0000s0sJSON::PP::::indent_length JSON::PP::indent_length
0000s0sJSON::PP::::is_bool JSON::PP::is_bool
0000s0sJSON::PP::::is_valid_utf8 JSON::PP::is_valid_utf8
0000s0sJSON::PP::::max_depth JSON::PP::max_depth
0000s0sJSON::PP::::max_size JSON::PP::max_size
0000s0sJSON::PP::::next_chr JSON::PP::next_chr
0000s0sJSON::PP::::null JSON::PP::null
0000s0sJSON::PP::::number JSON::PP::number
0000s0sJSON::PP::::object JSON::PP::object
0000s0sJSON::PP::::pretty JSON::PP::pretty
0000s0sJSON::PP::::sort_by JSON::PP::sort_by
0000s0sJSON::PP::::string JSON::PP::string
0000s0sJSON::PP::::to_json JSON::PP::to_json
0000s0sJSON::PP::::true JSON::PP::true
0000s0sJSON::PP::::value JSON::PP::value
0000s0sJSON::PP::::white JSON::PP::white
0000s0sJSON::PP::::word JSON::PP::word
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package JSON::PP;
2
3# JSON-2.0
4
53134µs1109µs
# spent 109µs within JSON::PP::BEGIN@5 which was called: # once (109µs+0s) by JSON::_load_pp at line 5
use 5.005;
# spent 109µs making 1 call to JSON::PP::BEGIN@5
6331µs222µ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
use strict;
# spent 17µs making 1 call to JSON::PP::BEGIN@6 # spent 5µs making 1 call to strict::import
7335µs2164µ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
use base qw(Exporter);
# spent 89µs making 1 call to JSON::PP::BEGIN@7 # spent 75µs making 1 call to base::import
8328µs250µ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
use overload;
# spent 30µs making 1 call to JSON::PP::BEGIN@8 # spent 21µs making 1 call to overload::import
9
10322µs15µs
# spent 5µs within JSON::PP::BEGIN@10 which was called: # once (5µs+0s) by JSON::_load_pp at line 10
use Carp ();
# spent 5µs making 1 call to JSON::PP::BEGIN@10
113177µs13.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
use B ();
# spent 3.78ms making 1 call to JSON::PP::BEGIN@11
12#use Devel::Peek;
13
1412µs$JSON::PP::VERSION = '2.27003';
15
1613µ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
21352µs2143µ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
use constant P_ASCII => 0;
# spent 79µs making 1 call to JSON::PP::BEGIN@21 # spent 64µs making 1 call to constant::import
22330µs277µ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
use constant P_LATIN1 => 1;
# spent 44µs making 1 call to JSON::PP::BEGIN@22 # spent 34µs making 1 call to constant::import
23330µs271µ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
use constant P_UTF8 => 2;
# spent 40µs making 1 call to JSON::PP::BEGIN@23 # spent 31µs making 1 call to constant::import
24330µs272µ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
use constant P_INDENT => 3;
# spent 40µs making 1 call to JSON::PP::BEGIN@24 # spent 32µs making 1 call to constant::import
25329µs270µ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
use constant P_CANONICAL => 4;
# spent 39µs making 1 call to JSON::PP::BEGIN@25 # spent 31µs making 1 call to constant::import
26330µs272µ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
use constant P_SPACE_BEFORE => 5;
# spent 40µs making 1 call to JSON::PP::BEGIN@26 # spent 32µs making 1 call to constant::import
27352µs271µ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
use constant P_SPACE_AFTER => 6;
# spent 40µs making 1 call to JSON::PP::BEGIN@27 # spent 31µs making 1 call to constant::import
28337µs2105µ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
use constant P_ALLOW_NONREF => 7;
# spent 58µs making 1 call to JSON::PP::BEGIN@28 # spent 46µs making 1 call to constant::import
29330µs276µ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
use constant P_SHRINK => 8;
# spent 43µs making 1 call to JSON::PP::BEGIN@29 # spent 33µs making 1 call to constant::import
30330µs272µ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
use constant P_ALLOW_BLESSED => 9;
# spent 41µs making 1 call to JSON::PP::BEGIN@30 # spent 32µs making 1 call to constant::import
31330µs273µ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
use constant P_CONVERT_BLESSED => 10;
# spent 42µs making 1 call to JSON::PP::BEGIN@31 # spent 31µs making 1 call to constant::import
32338µs271µ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
use constant P_RELAXED => 11;
# spent 40µs making 1 call to JSON::PP::BEGIN@32 # spent 31µs making 1 call to constant::import
33
34330µs276µ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
use constant P_LOOSE => 12;
# spent 43µs making 1 call to JSON::PP::BEGIN@34 # spent 33µs making 1 call to constant::import
35329µs270µ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
use constant P_ALLOW_BIGNUM => 13;
# spent 39µs making 1 call to JSON::PP::BEGIN@35 # spent 31µs making 1 call to constant::import
36354µs286µ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
use constant P_ALLOW_BAREKEY => 14;
# spent 49µs making 1 call to JSON::PP::BEGIN@36 # spent 36µs making 1 call to constant::import
37344µs292µ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
use constant P_ALLOW_SINGLEQUOTE => 15;
# spent 53µs making 1 call to JSON::PP::BEGIN@37 # spent 39µs making 1 call to constant::import
38330µs275µ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
use constant P_ESCAPE_SLASH => 16;
# spent 42µs making 1 call to JSON::PP::BEGIN@38 # spent 33µs making 1 call to constant::import
39346µs290µ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
use constant P_AS_NONBLESSED => 17;
# spent 51µs making 1 call to JSON::PP::BEGIN@39 # spent 39µs making 1 call to constant::import
40
413193µs287µ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
use constant P_ALLOW_UNKNOWN => 18;
# 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
BEGIN {
44441.83ms 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 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
8712.73ms12.43ms}
# spent 2.43ms making 1 call to JSON::PP::BEGIN@43
88
- -
91# Functions
92
93my %encode_allow_method
94114µ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 /;
98my %decode_allow_method
9916µs = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
100 allow_barekey max_size relaxed/;
101
102
1031400nsmy $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
sub encode_json ($) { # encode
106121µs3438µ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
110sub decode_json { # decode
111 ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
112}
113
114# Obsoleted
115
116sub to_json($) {
117 Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
118}
119
120
121sub from_json($) {
122 Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
123}
124
125
126# Methods
127
128
# spent 72µs within JSON::PP::new which was called: # once (72µs+0s) by JSON::PP::encode_json at line 106
sub new {
129376µ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
sub encode {
14419µs1352µs return $_[0]->PP_encode_json($_[1]);
# spent 352µs making 1 call to JSON::PP::PP_encode_json
145}
146
147
148sub decode {
149 return $_[0]->PP_decode_json($_[1], 0x00000000);
150}
151
152
153sub decode_prefix {
154 return $_[0]->PP_decode_json($_[1], 0x00000001);
155}
156
157
158# accessor
159
160
161# pretty printing
162
163sub pretty {
164 my ($self, $v) = @_;
165 my $enable = defined $v ? $v : 1;
166
167 if ($enable) { # indent_length(3) for JSON::XS compatibility
168 $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
169 }
170 else {
171 $self->indent(0)->space_before(0)->space_after(0);
172 }
173
174 $self;
175}
176
177# etc
178
179sub max_depth {
180 my $max = defined $_[1] ? $_[1] : 0x80000000;
181 $_[0]->{max_depth} = $max;
182 $_[0];
183}
184
185
186sub get_max_depth { $_[0]->{max_depth}; }
187
188
189sub max_size {
190 my $max = defined $_[1] ? $_[1] : 0;
191 $_[0]->{max_size} = $max;
192 $_[0];
193}
194
195
196sub get_max_size { $_[0]->{max_size}; }
197
198
199sub filter_json_object {
200 $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
201 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
202 $_[0];
203}
204
205sub filter_json_single_key_object {
206 if (@_ > 1) {
207 $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
208 }
209 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
210 $_[0];
211}
212
213sub indent_length {
214 if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
215 Carp::carp "The acceptable range of indent_length() is 0 to 15.";
216 }
217 else {
218 $_[0]->{indent_length} = $_[1];
219 }
220 $_[0];
221}
222
223sub get_indent_length {
224 $_[0]->{indent_length};
225}
226
227sub sort_by {
228 $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
229 $_[0];
230}
231
232sub allow_bigint {
233 Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
234}
235
236###############################
237
238###
239### Perl => JSON
240###
241
242
243{ # Convert
244
24521µs my $max_depth;
2461100ns my $indent;
2471200ns my $ascii;
2481100ns my $latin1;
2491200ns my $utf8;
2501200ns my $space_before;
2511200ns my $space_after;
2521100ns my $canonical;
2531200ns my $allow_blessed;
2541200ns my $convert_blessed;
255
2561100ns my $indent_length;
2571100ns my $escape_slash;
2581200ns my $bignum;
2591100ns my $as_nonblessed;
260
2611200ns my $depth;
2621200ns my $indent_count;
2631200ns 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
sub PP_encode_json {
2671522µ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
2931330µ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
# spent 330µs (47+283) within JSON::PP::object_to_json which was called 6 times, avg 55µs/call: # 4 times (24µs+-24µs) by JSON::PP::hash_to_json at line 381, avg 0s/call # once (10µs+320µs) by JSON::PP::PP_encode_json at line 293 # once (13µs+-13µs) by JSON::PP::array_to_json at line 416
sub object_to_json {
3102239µs my ($self, $obj) = @_;
311 my $type = ref($obj);
312
3132610µ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{
3524158µ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
sub hash_to_json {
3583260µ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 my $v = $obj->{$k};
38140s $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
38915µ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
390440µ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
sub array_to_json {
4001021µ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){
41610s 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
sub value_to_json {
42724121µs my ($self, $value) = @_;
428
429 return 'null' if(!defined $value);
430
431455µ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
43249µ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
442238µ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
48217µs my %esc = (
483 "\n" => '\n',
484 "\r" => '\r',
485 "\t" => '\t',
486 "\f" => '\f',
487 "\b" => '\b',
488 "\"" => '\"',
489 "\\" => '\\\\',
490 "\'" => '\\\'',
491 );
492
493
494
# spent 79µs (60+19) within JSON::PP::string_to_json which was called 6 times, avg 13µs/call: # 4 times (30µs+11µs) by JSON::PP::hash_to_json at line 390, avg 10µs/call # 2 times (30µs+8µs) by JSON::PP::value_to_json at line 442, avg 19µs/call
sub string_to_json {
4954883µs my ($self, $arg) = @_;
496
49766µ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);
49963µ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
509610µ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
sub _sort {
53826µ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
572sub _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
584sub _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
596sub _encode_surrogates { # from perlunicode
597 my $uni = $_[0] - 0x10000;
598 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
599}
600
601
602sub _is_bignum {
603 $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
604}
605
- -
608#
609# JSON => Perl
610#
611
6121200nsmy $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
BEGIN {
61555362µs my $checkint = 1111;
616 for my $d (5..30) {
617 $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
6191738µ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 }
6241326µs1400µs}
# spent 400µs making 1 call to JSON::PP::BEGIN@614
625
626{ # PARSE
627
62826µ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
6391200ns my $text; # json data
6401100ns my $at; # offset
6411200ns my $ch; # 1chracter
6421200ns my $len; # text length (changed according to UTF8 or NON UTF8)
643 # INTERNAL
6441200ns my $depth; # nest counter
6451100ns my $encoding; # json text encoding
6461200ns my $is_valid_utf8; # temp variable
6471200ns my $utf8_len; # utf8 byte length
648 # FLAGS
6491100ns my $utf8; # must be utf8
6501200ns my $max_depth; # max nest nubmer of objects and arrays
6511100ns my $max_size;
6521100ns my $relaxed;
6531200ns my $cb_object;
6541100ns my $cb_sk_object;
655
6561200ns my $F_HOOK;
657
6581200ns my $allow_bigint; # using Math::BigInt
6591100ns my $singlequote; # loosely quoting
6601200ns my $loose; #
6611800ns 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) {
69632.80ms238µ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
use bytes;
# 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
1285sub _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
1293sub _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
BEGIN {
1308232µ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 }
13201229µs134µs}
# spent 34µs making 1 call to JSON::PP::BEGIN@1307
1321
1322
1323# shamely copied and modified from JSON::XS code.
1324
1325135µs$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
132611µs$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1327
1328sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
1329
1330sub true { $JSON::PP::true }
1331sub false { $JSON::PP::false }
1332sub null { undef; }
1333
1334###############################
1335
1336package 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
use overload (
1340 "0+" => sub { ${$_[0]} },
1341 "++" => sub { $_[0] = ${$_[0]} + 1 },
1342 "--" => sub { $_[0] = ${$_[0]} - 1 },
1343163µs fallback => 1,
# spent 63µs making 1 call to overload::import
1344346µs181µs);
# spent 81µs making 1 call to JSON::PP::Boolean::BEGIN@1339
1345
1346
1347###############################
1348
1349package JSON::PP::IncrParser;
1350
1351340µs224µ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
use strict;
# spent 18µs making 1 call to JSON::PP::IncrParser::BEGIN@1351 # spent 5µs making 1 call to strict::import
1352
1353336µs2151µ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
use constant INCR_M_WS => 0; # initial whitespace skipping
# spent 81µs making 1 call to JSON::PP::IncrParser::BEGIN@1353 # spent 70µs making 1 call to constant::import
1354330µs275µ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
use constant INCR_M_STR => 1; # inside string
# spent 42µs making 1 call to JSON::PP::IncrParser::BEGIN@1354 # spent 33µs making 1 call to constant::import
1355337µs271µ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
use constant INCR_M_BS => 2; # inside backslash
# spent 40µs making 1 call to JSON::PP::IncrParser::BEGIN@1355 # spent 31µs making 1 call to constant::import
1356330µs274µ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
use constant INCR_M_JSON => 3; # outside anything, count nesting
# spent 42µs making 1 call to JSON::PP::IncrParser::BEGIN@1356 # spent 32µs making 1 call to constant::import
1357327µs269µ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
use constant INCR_M_C0 => 4;
# spent 39µs making 1 call to JSON::PP::IncrParser::BEGIN@1357 # spent 30µs making 1 call to constant::import
13583877µs269µ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
use constant INCR_M_C1 => 5;
# spent 39µs making 1 call to JSON::PP::IncrParser::BEGIN@1358 # spent 30µs making 1 call to constant::import
1359
13601500ns$JSON::PP::IncrParser::VERSION = '1.01';
1361
136212µsmy $unpack_format = $] < 5.006 ? 'C*' : 'U*';
1363
1364sub 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
1376sub 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
1426sub _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
1498sub 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
1506sub 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
1513sub 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
1525124µs1;
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:match; # opcode
# spent 9µs within JSON::PP::CORE:subst which was called 12 times, avg 725ns/call: # 6 times (6µs+0s) by JSON::PP::string_to_json at line 497, avg 1µs/call # 6 times (3µs+0s) by JSON::PP::string_to_json at line 499, avg 433ns/call
sub JSON::PP::CORE:subst; # opcode