← Index
NYTProf Performance Profile   « line view »
For ./view
  Run on Fri Jul 31 18:42:36 2015
Reported on Fri Jul 31 18:48:13 2015

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