Profile of JSON/PP.pm

Filename	/usr/share/perl5/JSON/PP.pm
Statements	Executed 412 statements in 11.3ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	2.42ms	3.78ms	JSON::PP::::BEGIN@11 JSON::PP::BEGIN@11
1	1	1	2.34ms	2.43ms	JSON::PP::::BEGIN@43 JSON::PP::BEGIN@43
1	1	1	363µs	400µs	JSON::PP::::BEGIN@614 JSON::PP::BEGIN@614
1	1	1	109µs	109µs	JSON::PP::::BEGIN@5 JSON::PP::BEGIN@5
1	1	1	72µs	72µs	JSON::PP::::new JSON::PP::new
1	1	1	63µs	290µs	JSON::PP::::hash_to_json JSON::PP::hash_to_json
6	2	1	60µs	79µs	JSON::PP::::string_to_json JSON::PP::string_to_json
4	1	1	55µs	158µs	JSON::PP::::value_to_json JSON::PP::value_to_json
6	3	1	47µs	330µs	JSON::PP::::object_to_json JSON::PP::object_to_json (recurses: max depth 2, inclusive time 484µs)
17	1	1	38µs	38µs	JSON::PP::::CORE:match JSON::PP::CORE:match (opcode)
1	1	1	34µs	34µs	JSON::PP::::BEGIN@1307 JSON::PP::BEGIN@1307
1	1	1	28µs	466µs	JSON::PP::::encode_json JSON::PP::encode_json
1	1	1	24µs	31µs	JSON::PP::::BEGIN@696 JSON::PP::BEGIN@696
1	1	1	21µs	352µs	JSON::PP::::PP_encode_json JSON::PP::PP_encode_json
1	1	1	18µs	81µs	JSON::PP::Boolean::::BEGIN@1339 JSON::PP::Boolean::BEGIN@1339
1	1	1	17µs	320µs	JSON::PP::::array_to_json JSON::PP::array_to_json
1	1	1	16µs	79µs	JSON::PP::::BEGIN@21 JSON::PP::BEGIN@21
1	1	1	14µs	53µs	JSON::PP::::BEGIN@37 JSON::PP::BEGIN@37
1	1	1	14µs	89µs	JSON::PP::::BEGIN@7 JSON::PP::BEGIN@7
1	1	1	13µs	18µs	JSON::PP::IncrParser::::BEGIN@1351JSON::PP::IncrParser::BEGIN@1351
1	1	1	13µs	49µs	JSON::PP::::BEGIN@36 JSON::PP::BEGIN@36
1	1	1	12µs	17µs	JSON::PP::::BEGIN@6 JSON::PP::BEGIN@6
1	1	1	12µs	58µs	JSON::PP::::BEGIN@28 JSON::PP::BEGIN@28
1	1	1	12µs	51µs	JSON::PP::::BEGIN@39 JSON::PP::BEGIN@39
1	1	1	12µs	81µs	JSON::PP::IncrParser::::BEGIN@1353JSON::PP::IncrParser::BEGIN@1353
1	1	1	10µs	49µs	JSON::PP::::BEGIN@41 JSON::PP::BEGIN@41
1	1	1	10µs	42µs	JSON::PP::::BEGIN@31 JSON::PP::BEGIN@31
1	1	1	10µs	40µs	JSON::PP::::BEGIN@27 JSON::PP::BEGIN@27
1	1	1	10µs	44µs	JSON::PP::::BEGIN@22 JSON::PP::BEGIN@22
1	1	1	9µs	42µs	JSON::PP::::BEGIN@38 JSON::PP::BEGIN@38
1	1	1	9µs	43µs	JSON::PP::::BEGIN@34 JSON::PP::BEGIN@34
1	1	1	9µs	43µs	JSON::PP::::BEGIN@29 JSON::PP::BEGIN@29
1	1	1	9µs	42µs	JSON::PP::IncrParser::::BEGIN@1356JSON::PP::IncrParser::BEGIN@1356
1	1	1	9µs	30µs	JSON::PP::::BEGIN@8 JSON::PP::BEGIN@8
1	1	1	9µs	41µs	JSON::PP::::BEGIN@30 JSON::PP::BEGIN@30
12	2	1	9µs	9µs	JSON::PP::::CORE:subst JSON::PP::CORE:subst (opcode)
1	1	1	8µs	39µs	JSON::PP::::BEGIN@25 JSON::PP::BEGIN@25
1	1	1	8µs	40µs	JSON::PP::::BEGIN@23 JSON::PP::BEGIN@23
1	1	1	8µs	40µs	JSON::PP::IncrParser::::BEGIN@1355JSON::PP::IncrParser::BEGIN@1355
1	1	1	8µs	40µs	JSON::PP::::BEGIN@26 JSON::PP::BEGIN@26
1	1	1	8µs	39µs	JSON::PP::IncrParser::::BEGIN@1358JSON::PP::IncrParser::BEGIN@1358
1	1	1	8µs	42µs	JSON::PP::IncrParser::::BEGIN@1354JSON::PP::IncrParser::BEGIN@1354
1	1	1	8µs	40µs	JSON::PP::::BEGIN@32 JSON::PP::BEGIN@32
1	1	1	8µs	40µs	JSON::PP::::BEGIN@24 JSON::PP::BEGIN@24
1	1	1	8µs	39µs	JSON::PP::IncrParser::::BEGIN@1357JSON::PP::IncrParser::BEGIN@1357
1	1	1	8µs	39µs	JSON::PP::::BEGIN@35 JSON::PP::BEGIN@35
1	1	1	7µs	359µs	JSON::PP::::encode JSON::PP::encode
1	1	1	5µs	5µs	JSON::PP::::BEGIN@10 JSON::PP::BEGIN@10
1	1	1	5µs	5µs	JSON::PP::::_sort JSON::PP::_sort
0	0	0	0s	0s	JSON::PP::Boolean::::__ANON__[:1340] JSON::PP::Boolean::__ANON__[:1340]
0	0	0	0s	0s	JSON::PP::Boolean::::__ANON__[:1341] JSON::PP::Boolean::__ANON__[:1341]
0	0	0	0s	0s	JSON::PP::Boolean::::__ANON__[:1342] JSON::PP::Boolean::__ANON__[:1342]
0	0	0	0s	0s	JSON::PP::IncrParser::::_incr_parseJSON::PP::IncrParser::_incr_parse
0	0	0	0s	0s	JSON::PP::IncrParser::::incr_parseJSON::PP::IncrParser::incr_parse
0	0	0	0s	0s	JSON::PP::IncrParser::::incr_resetJSON::PP::IncrParser::incr_reset
0	0	0	0s	0s	JSON::PP::IncrParser::::incr_skipJSON::PP::IncrParser::incr_skip
0	0	0	0s	0s	JSON::PP::IncrParser::::incr_textJSON::PP::IncrParser::incr_text
0	0	0	0s	0s	JSON::PP::IncrParser::::newJSON::PP::IncrParser::new
0	0	0	0s	0s	JSON::PP::::PP_decode_box JSON::PP::PP_decode_box
0	0	0	0s	0s	JSON::PP::::PP_decode_json JSON::PP::PP_decode_json
0	0	0	0s	0s	JSON::PP::::PP_encode_box JSON::PP::PP_encode_box
0	0	0	0s	0s	JSON::PP::::__ANON__[:1318] JSON::PP::__ANON__[:1318]
0	0	0	0s	0s	JSON::PP::::__ANON__[:135] JSON::PP::__ANON__[:135]
0	0	0	0s	0s	JSON::PP::::__ANON__[:282] JSON::PP::__ANON__[:282]
0	0	0	0s	0s	JSON::PP::::__ANON__[:287] JSON::PP::__ANON__[:287]
0	0	0	0s	0s	JSON::PP::::_decode_surrogates JSON::PP::_decode_surrogates
0	0	0	0s	0s	JSON::PP::::_decode_unicode JSON::PP::_decode_unicode
0	0	0	0s	0s	JSON::PP::::_down_indent JSON::PP::_down_indent
0	0	0	0s	0s	JSON::PP::::_encode_ascii JSON::PP::_encode_ascii
0	0	0	0s	0s	JSON::PP::::_encode_latin1 JSON::PP::_encode_latin1
0	0	0	0s	0s	JSON::PP::::_encode_surrogates JSON::PP::_encode_surrogates
0	0	0	0s	0s	JSON::PP::::_is_bignum JSON::PP::_is_bignum
0	0	0	0s	0s	JSON::PP::::_json_object_hook JSON::PP::_json_object_hook
0	0	0	0s	0s	JSON::PP::::_up_indent JSON::PP::_up_indent
0	0	0	0s	0s	JSON::PP::::allow_bigint JSON::PP::allow_bigint
0	0	0	0s	0s	JSON::PP::::array JSON::PP::array
0	0	0	0s	0s	JSON::PP::::bareKey JSON::PP::bareKey
0	0	0	0s	0s	JSON::PP::::blessed_to_json JSON::PP::blessed_to_json
0	0	0	0s	0s	JSON::PP::::decode JSON::PP::decode
0	0	0	0s	0s	JSON::PP::::decode_error JSON::PP::decode_error
0	0	0	0s	0s	JSON::PP::::decode_json JSON::PP::decode_json
0	0	0	0s	0s	JSON::PP::::decode_prefix JSON::PP::decode_prefix
0	0	0	0s	0s	JSON::PP::::encode_error JSON::PP::encode_error
0	0	0	0s	0s	JSON::PP::::false JSON::PP::false
0	0	0	0s	0s	JSON::PP::::filter_json_object JSON::PP::filter_json_object
0	0	0	0s	0s	JSON::PP::filter_json_single_key_object
0	0	0	0s	0s	JSON::PP::::from_json JSON::PP::from_json
0	0	0	0s	0s	JSON::PP::::get_indent_length JSON::PP::get_indent_length
0	0	0	0s	0s	JSON::PP::::get_max_depth JSON::PP::get_max_depth
0	0	0	0s	0s	JSON::PP::::get_max_size JSON::PP::get_max_size
0	0	0	0s	0s	JSON::PP::::indent_length JSON::PP::indent_length
0	0	0	0s	0s	JSON::PP::::is_bool JSON::PP::is_bool
0	0	0	0s	0s	JSON::PP::::is_valid_utf8 JSON::PP::is_valid_utf8
0	0	0	0s	0s	JSON::PP::::max_depth JSON::PP::max_depth
0	0	0	0s	0s	JSON::PP::::max_size JSON::PP::max_size
0	0	0	0s	0s	JSON::PP::::next_chr JSON::PP::next_chr
0	0	0	0s	0s	JSON::PP::::null JSON::PP::null
0	0	0	0s	0s	JSON::PP::::number JSON::PP::number
0	0	0	0s	0s	JSON::PP::::object JSON::PP::object
0	0	0	0s	0s	JSON::PP::::pretty JSON::PP::pretty
0	0	0	0s	0s	JSON::PP::::sort_by JSON::PP::sort_by
0	0	0	0s	0s	JSON::PP::::string JSON::PP::string
0	0	0	0s	0s	JSON::PP::::to_json JSON::PP::to_json
0	0	0	0s	0s	JSON::PP::::true JSON::PP::true
0	0	0	0s	0s	JSON::PP::::value JSON::PP::value
0	0	0	0s	0s	JSON::PP::::white JSON::PP::white
0	0	0	0s	0s	JSON::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
1					package JSON::PP;
2
3					# JSON-2.0
4
5	3	134µs	1	109µs	# spent 109µs within JSON::PP::BEGIN@5 which was called: # once (109µs+0s) by JSON::_load_pp at line 5 use 5.005; # spent 109µs making 1 call to JSON::PP::BEGIN@5
6	3	31µs	2	22µs	# spent 17µs (12+5) within JSON::PP::BEGIN@6 which was called: # once (12µs+5µs) by JSON::_load_pp at line 6 use strict; # spent 17µs making 1 call to JSON::PP::BEGIN@6 # spent 5µs making 1 call to strict::import
7	3	35µs	2	164µs	# spent 89µs (14+75) within JSON::PP::BEGIN@7 which was called: # once (14µs+75µs) by JSON::_load_pp at line 7 use base qw(Exporter); # spent 89µs making 1 call to JSON::PP::BEGIN@7 # spent 75µs making 1 call to base::import
8	3	28µs	2	50µs	# spent 30µs (9+21) within JSON::PP::BEGIN@8 which was called: # once (9µs+21µs) by JSON::_load_pp at line 8 use overload; # spent 30µs making 1 call to JSON::PP::BEGIN@8 # spent 21µs making 1 call to overload::import
9
10	3	22µs	1	5µs	# spent 5µs within JSON::PP::BEGIN@10 which was called: # once (5µs+0s) by JSON::_load_pp at line 10 use Carp (); # spent 5µs making 1 call to JSON::PP::BEGIN@10
11	3	177µs	1	3.78ms	# spent 3.78ms (2.42+1.37) within JSON::PP::BEGIN@11 which was called: # once (2.42ms+1.37ms) by JSON::_load_pp at line 11 use B (); # spent 3.78ms making 1 call to JSON::PP::BEGIN@11
12					#use Devel::Peek;
13
14	1	2µs			$JSON::PP::VERSION = '2.27003';
15
16	1	3µs			@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
17
18					# instead of hash-access, i tried index-access for speed.
19					# but this method is not faster than what i expected. so it will be changed.
20
21	3	52µs	2	143µs	# spent 79µs (16+63) within JSON::PP::BEGIN@21 which was called: # once (16µs+63µs) by JSON::_load_pp at line 21 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
22	3	30µs	2	77µs	# spent 44µs (10+34) within JSON::PP::BEGIN@22 which was called: # once (10µs+34µs) by JSON::_load_pp at line 22 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
23	3	30µs	2	71µs	# spent 40µs (8+31) within JSON::PP::BEGIN@23 which was called: # once (8µs+31µs) by JSON::_load_pp at line 23 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
24	3	30µs	2	72µs	# spent 40µs (8+32) within JSON::PP::BEGIN@24 which was called: # once (8µs+32µs) by JSON::_load_pp at line 24 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
25	3	29µs	2	70µs	# spent 39µs (8+31) within JSON::PP::BEGIN@25 which was called: # once (8µs+31µs) by JSON::_load_pp at line 25 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
26	3	30µs	2	72µs	# spent 40µs (8+32) within JSON::PP::BEGIN@26 which was called: # once (8µs+32µs) by JSON::_load_pp at line 26 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
27	3	52µs	2	71µs	# spent 40µs (10+30) within JSON::PP::BEGIN@27 which was called: # once (10µs+30µs) by JSON::_load_pp at line 27 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
28	3	37µs	2	105µs	# spent 58µs (12+46) within JSON::PP::BEGIN@28 which was called: # once (12µs+46µs) by JSON::_load_pp at line 28 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
29	3	30µs	2	76µs	# spent 43µs (9+34) within JSON::PP::BEGIN@29 which was called: # once (9µs+34µs) by JSON::_load_pp at line 29 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
30	3	30µs	2	72µs	# spent 41µs (9+32) within JSON::PP::BEGIN@30 which was called: # once (9µs+32µs) by JSON::_load_pp at line 30 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
31	3	30µs	2	73µs	# spent 42µs (10+31) within JSON::PP::BEGIN@31 which was called: # once (10µs+31µs) by JSON::_load_pp at line 31 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
32	3	38µs	2	71µs	# spent 40µs (8+31) within JSON::PP::BEGIN@32 which was called: # once (8µs+31µs) by JSON::_load_pp at line 32 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
34	3	30µs	2	76µs	# spent 43µs (9+33) within JSON::PP::BEGIN@34 which was called: # once (9µs+33µs) by JSON::_load_pp at line 34 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
35	3	29µs	2	70µs	# spent 39µs (8+31) within JSON::PP::BEGIN@35 which was called: # once (8µs+31µs) by JSON::_load_pp at line 35 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
36	3	54µs	2	86µs	# spent 49µs (13+36) within JSON::PP::BEGIN@36 which was called: # once (13µs+36µs) by JSON::_load_pp at line 36 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
37	3	44µs	2	92µs	# spent 53µs (14+39) within JSON::PP::BEGIN@37 which was called: # once (14µs+39µs) by JSON::_load_pp at line 37 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
38	3	30µs	2	75µs	# spent 42µs (9+33) within JSON::PP::BEGIN@38 which was called: # once (9µs+33µs) by JSON::_load_pp at line 38 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
39	3	46µs	2	90µs	# spent 51µs (12+39) within JSON::PP::BEGIN@39 which was called: # once (12µs+39µs) by JSON::_load_pp at line 39 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
41	3	193µs	2	87µs	# spent 49µs (10+38) within JSON::PP::BEGIN@41 which was called: # once (10µs+38µs) by JSON::_load_pp at line 41 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 {
44	44	1.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
87	1	2.73ms	1	2.43ms	} # spent 2.43ms making 1 call to JSON::PP::BEGIN@43
88
- -
91					# Functions
92
93					my %encode_allow_method
94	1	14µs			= map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
95					allow_blessed convert_blessed indent indent_length allow_bignum
96					as_nonblessed
97					/;
98					my %decode_allow_method
99	1	6µs			= map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
100					allow_barekey max_size relaxed/;
101
102
103	1	400ns			my $JSON; # cache
104
105					# spent 466µs (28+438) within JSON::PP::encode_json which was called: # once (28µs+438µs) by main::RUNTIME at line 648 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl sub encode_json ($) { # encode
106	1	21µs	3	438µs	($JSON \|\|= __PACKAGE__->new->utf8)->encode(@_); # spent 359µs making 1 call to JSON::PP::encode # spent 72µs making 1 call to JSON::PP::new # spent 7µs making 1 call to JSON::PP::utf8
107					}
108
109
110					sub decode_json { # decode
111					($JSON \|\|= __PACKAGE__->new->utf8)->decode(@_);
112					}
113
114					# Obsoleted
115
116					sub to_json($) {
117					Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
118					}
119
120
121					sub from_json($) {
122					Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
123					}
124
125
126					# Methods
127
128					# spent 72µs within JSON::PP::new which was called: # once (72µs+0s) by JSON::PP::encode_json at line 106 sub new {
129	3	76µs			my $class = shift;
130					my $self = {
131					max_depth => 512,
132					max_size => 0,
133					indent => 0,
134					FLAGS => 0,
135					fallback => sub { encode_error('Invalid value. JSON can only reference.') },
136					indent_length => 3,
137					};
138
139					bless $self, $class;
140					}
141
142
143					# spent 359µs (7+352) within JSON::PP::encode which was called: # once (7µs+352µs) by JSON::PP::encode_json at line 106 sub encode {
144	1	9µs	1	352µs	return $_[0]->PP_encode_json($_[1]); # spent 352µs making 1 call to JSON::PP::PP_encode_json
145					}
146
147
148					sub decode {
149					return $_[0]->PP_decode_json($_[1], 0x00000000);
150					}
151
152
153					sub decode_prefix {
154					return $_[0]->PP_decode_json($_[1], 0x00000001);
155					}
156
157
158					# accessor
159
160
161					# pretty printing
162
163					sub pretty {
164					my ($self, $v) = @_;
165					my $enable = defined $v ? $v : 1;
166
167					if ($enable) { # indent_length(3) for JSON::XS compatibility
168					$self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
169					}
170					else {
171					$self->indent(0)->space_before(0)->space_after(0);
172					}
173
174					$self;
175					}
176
177					# etc
178
179					sub max_depth {
180					my $max = defined $_[1] ? $_[1] : 0x80000000;
181					$_[0]->{max_depth} = $max;
182					$_[0];
183					}
184
185
186					sub get_max_depth { $_[0]->{max_depth}; }
187
188
189					sub max_size {
190					my $max = defined $_[1] ? $_[1] : 0;
191					$_[0]->{max_size} = $max;
192					$_[0];
193					}
194
195
196					sub get_max_size { $_[0]->{max_size}; }
197
198
199					sub filter_json_object {
200					$_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
201					$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
202					$_[0];
203					}
204
205					sub filter_json_single_key_object {
206					if (@_ > 1) {
207					$_[0]->{cb_sk_object}->{$_[1]} = $_[2];
208					}
209					$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
210					$_[0];
211					}
212
213					sub indent_length {
214					if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
215					Carp::carp "The acceptable range of indent_length() is 0 to 15.";
216					}
217					else {
218					$_[0]->{indent_length} = $_[1];
219					}
220					$_[0];
221					}
222
223					sub get_indent_length {
224					$_[0]->{indent_length};
225					}
226
227					sub sort_by {
228					$_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
229					$_[0];
230					}
231
232					sub allow_bigint {
233					Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
234					}
235
236					###############################
237
238					###
239					### Perl => JSON
240					###
241
242
243					{ # Convert
244
245	2	1µs			my $max_depth;
246	1	100ns			my $indent;
247	1	200ns			my $ascii;
248	1	100ns			my $latin1;
249	1	200ns			my $utf8;
250	1	200ns			my $space_before;
251	1	200ns			my $space_after;
252	1	100ns			my $canonical;
253	1	200ns			my $allow_blessed;
254	1	200ns			my $convert_blessed;
255
256	1	100ns			my $indent_length;
257	1	100ns			my $escape_slash;
258	1	200ns			my $bignum;
259	1	100ns			my $as_nonblessed;
260
261	1	200ns			my $depth;
262	1	200ns			my $indent_count;
263	1	200ns			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 {
267	15	22µs			my $self = shift;
268					my $obj = shift;
269
270					$indent_count = 0;
271					$depth = 0;
272
273					my $idx = $self->{PROPS};
274
275					($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
276					$convert_blessed, $escape_slash, $bignum, $as_nonblessed)
277					= @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
278					P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
279
280					($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
281
282					$keysort = $canonical ? sub { $a cmp $b } : undef;
283
284					if ($self->{sort_by}) {
285					$keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
286					: $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
287					: sub { $a cmp $b };
288					}
289
290					encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
291					if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
292
293			1	330µs	my $str = $self->object_to_json($obj); # spent 330µs making 1 call to JSON::PP::object_to_json
294
295					$str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
296
297					unless ($ascii or $latin1 or $utf8) {
298					utf8::upgrade($str);
299					}
300
301					if ($idx->[ P_SHRINK ]) {
302					utf8::downgrade($str, 1);
303					}
304
305					return $str;
306					}
307
308
309					# 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 {
310	22	39µs			my ($self, $obj) = @_;
311					my $type = ref($obj);
312
313			2	610µs	if($type eq 'HASH'){ # spent 320µs making 1 call to JSON::PP::array_to_json # spent 290µs making 1 call to JSON::PP::hash_to_json
314					return $self->hash_to_json($obj);
315					}
316					elsif($type eq 'ARRAY'){
317					return $self->array_to_json($obj);
318					}
319					elsif ($type) { # blessed object?
320					if (blessed($obj)) {
321
322					return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
323
324					if ( $convert_blessed and $obj->can('TO_JSON') ) {
325					my $result = $obj->TO_JSON();
326					if ( defined $result and overload::Overloaded( $obj ) ) {
327					if ( overload::StrVal( $obj ) eq $result ) {
328					encode_error( sprintf(
329					"%s::TO_JSON method returned same object as was passed instead of a new one",
330					ref $obj
331					) );
332					}
333					}
334
335					return $self->object_to_json( $result );
336					}
337
338					return "$obj" if ( $bignum and _is_bignum($obj) );
339					return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
340
341					encode_error( sprintf("encountered object '%s', but neither allow_blessed "
342					. "nor convert_blessed settings are enabled", $obj)
343					) unless ($allow_blessed);
344
345					return 'null';
346					}
347					else {
348					return $self->value_to_json($obj);
349					}
350					}
351					else{
352			4	158µs	return $self->value_to_json($obj); # spent 158µs making 4 calls to JSON::PP::value_to_json, avg 39µs/call
353					}
354					}
355
356
357					# spent 290µs (63+226) within JSON::PP::hash_to_json which was called: # once (63µs+226µs) by JSON::PP::object_to_json at line 313 sub hash_to_json {
358	32	60µ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};
381			4	0s	$res{$k} = $self->object_to_json($v) \|\| $self->value_to_json($v); # spent 181µs making 4 calls to JSON::PP::object_to_json, avg 45µs/call, recursion: max depth 2, sum of overlapping time 181µs
382					$has = 1 unless ( $has );
383					}
384
385					--$depth;
386					$self->_down_indent() if ($indent);
387
388					return '{' . ( $has ? $pre : '' ) # indent
389			1	5µs	. ( $has ? join(",$pre", map { utf8::decode($_) if ($] < 5.008); # key for Perl 5.6 # spent 5µs making 1 call to JSON::PP::_sort
390			4	40µs	string_to_json($self, $_) . $del . $res{$_} # key : value # spent 40µs making 4 calls to JSON::PP::string_to_json, avg 10µs/call
391					} _sort( $self, \%res )
392					) . $post # indent
393					: ''
394					)
395					. '}';
396					}
397
398
399					# spent 320µs (17+303) within JSON::PP::array_to_json which was called: # once (17µs+303µs) by JSON::PP::object_to_json at line 313 sub array_to_json {
400	10	21µs			my ($self, $obj) = @_;
401					my @res;
402
403					encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
404					if (++$depth > $max_depth);
405
406					my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
407
408					if (my $tie_class = tied @$obj) {
409					if ( $tie_class->can('TIEARRAY') ) {
410					$tie_class =~ s/=.+$//;
411					tie @res, $tie_class;
412					}
413					}
414
415					for my $v (@$obj){
416			1	0s	push @res, $self->object_to_json($v) \|\| $self->value_to_json($v); # spent 303µs making 1 call to JSON::PP::object_to_json, recursion: max depth 1, sum of overlapping time 303µs
417					}
418
419					--$depth;
420					$self->_down_indent() if ($indent);
421
422					return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
423					}
424
425
426					# spent 158µs (55+102) within JSON::PP::value_to_json which was called 4 times, avg 39µs/call: # 4 times (55µs+102µs) by JSON::PP::object_to_json at line 352, avg 39µs/call sub value_to_json {
427	24	121µs			my ($self, $value) = @_;
428
429					return 'null' if(!defined $value);
430
431			4	55µs	my $b_obj = B::svref_2object(\$value); # for round trip problem # spent 55µs making 4 calls to B::svref_2object, avg 14µs/call
432			4	9µs	my $flags = $b_obj->FLAGS; # spent 9µs making 4 calls to B::SV::FLAGS, avg 2µs/call
433
434					return $value # as is
435					if ( ( $flags & B::SVf_IOK or $flags & B::SVp_IOK
436					or $flags & B::SVf_NOK or $flags & B::SVp_NOK
437					) and !($flags & B::SVf_POK )
438					); # SvTYPE is IV or NV?
439
440					my $type = ref($value);
441
442			2	38µs	if(!$type){ # spent 38µs making 2 calls to JSON::PP::string_to_json, avg 19µs/call
443					return string_to_json($self, $value);
444					}
445					elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
446					return $$value == 1 ? 'true' : 'false';
447					}
448					elsif ($type) {
449					if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
450					return $self->value_to_json("$value");
451					}
452
453					if ($type eq 'SCALAR' and defined $$value) {
454					return $$value eq '1' ? 'true'
455					: $$value eq '0' ? 'false'
456					: $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
457					: encode_error("cannot encode reference to scalar");
458					}
459
460					if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
461					return 'null';
462					}
463					else {
464					if ( $type eq 'SCALAR' or $type eq 'REF' ) {
465					encode_error("cannot encode reference to scalar");
466					}
467					else {
468					encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
469					}
470					}
471
472					}
473					else {
474					return $self->{fallback}->($value)
475					if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
476					return 'null';
477					}
478
479					}
480
481
482	1	7µ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 {
495	48	83µs			my ($self, $arg) = @_;
496
497			6	6µs	$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; # spent 6µs making 6 calls to JSON::PP::CORE:subst, avg 1µs/call
498					$arg =~ s/\//\\\//g if ($escape_slash);
499			6	3µs	$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; # spent 3µs making 6 calls to JSON::PP::CORE:subst, avg 433ns/call
500
501					if ($ascii) {
502					$arg = JSON_PP_encode_ascii($arg);
503					}
504
505					if ($latin1) {
506					$arg = JSON_PP_encode_latin1($arg);
507					}
508
509			6	10µs	if ($utf8) { # spent 10µs making 6 calls to utf8::encode, avg 2µs/call
510					utf8::encode($arg);
511					}
512
513					return '"' . $arg . '"';
514					}
515
516
517					sub blessed_to_json {
518					my $b_obj = B::svref_2object($_[1]);
519					if ($b_obj->isa('B::HV')) {
520					return $_[0]->hash_to_json($_[1]);
521					}
522					elsif ($b_obj->isa('B::AV')) {
523					return $_[0]->array_to_json($_[1]);
524					}
525					else {
526					return 'null';
527					}
528					}
529
530
531					sub encode_error {
532					my $error = shift;
533					Carp::croak "$error";
534					}
535
536
537					# spent 5µs within JSON::PP::_sort which was called: # once (5µs+0s) by JSON::PP::hash_to_json at line 389 sub _sort {
538	2	6µs			my ($self, $res) = @_;
539					defined $keysort ? (sort $keysort (keys %$res)) : keys %$res;
540					}
541
542
543					sub _up_indent {
544					my $self = shift;
545					my $space = ' ' x $indent_length;
546
547					my ($pre,$post) = ('','');
548
549					$post = "\n" . $space x $indent_count;
550
551					$indent_count++;
552
553					$pre = "\n" . $space x $indent_count;
554
555					return ($pre,$post);
556					}
557
558
559					sub _down_indent { $indent_count--; }
560
561
562					sub PP_encode_box {
563					{
564					depth => $depth,
565					indent_count => $indent_count,
566					};
567					}
568
569					} # Convert
570
571
572					sub _encode_ascii {
573					join('',
574					map {
575					$_ <= 127 ?
576					chr($_) :
577					$_ <= 65535 ?
578					sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
579					} unpack('U*', $_[0])
580					);
581					}
582
583
584					sub _encode_latin1 {
585					join('',
586					map {
587					$_ <= 255 ?
588					chr($_) :
589					$_ <= 65535 ?
590					sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
591					} unpack('U*', $_[0])
592					);
593					}
594
595
596					sub _encode_surrogates { # from perlunicode
597					my $uni = $_[0] - 0x10000;
598					return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
599					}
600
601
602					sub _is_bignum {
603					$_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
604					}
605
- -
608					#
609					# JSON => Perl
610					#
611
612	1	200ns			my $max_intsize;
613
614					# spent 400µs (363+37) within JSON::PP::BEGIN@614 which was called: # once (363µs+37µs) by JSON::_load_pp at line 624 BEGIN {
615	55	362µ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
619			17	38µs	if ($int =~ /[eE]/) { # spent 38µs making 17 calls to JSON::PP::CORE:match, avg 2µs/call
620					$max_intsize = $d - 1;
621					last;
622					}
623					}
624	1	326µs	1	400µs	} # spent 400µs making 1 call to JSON::PP::BEGIN@614
625
626					{ # PARSE
627
628	2	6µs			my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
629					b => "\x8",
630					t => "\x9",
631					n => "\xA",
632					f => "\xC",
633					r => "\xD",
634					'\\' => '\\',
635					'"' => '"',
636					'/' => '/',
637					);
638
639	1	200ns			my $text; # json data
640	1	100ns			my $at; # offset
641	1	200ns			my $ch; # 1chracter
642	1	200ns			my $len; # text length (changed according to UTF8 or NON UTF8)
643					# INTERNAL
644	1	200ns			my $depth; # nest counter
645	1	100ns			my $encoding; # json text encoding
646	1	200ns			my $is_valid_utf8; # temp variable
647	1	200ns			my $utf8_len; # utf8 byte length
648					# FLAGS
649	1	100ns			my $utf8; # must be utf8
650	1	200ns			my $max_depth; # max nest nubmer of objects and arrays
651	1	100ns			my $max_size;
652	1	100ns			my $relaxed;
653	1	200ns			my $cb_object;
654	1	100ns			my $cb_sk_object;
655
656	1	200ns			my $F_HOOK;
657
658	1	200ns			my $allow_bigint; # using Math::BigInt
659	1	100ns			my $singlequote; # loosely quoting
660	1	200ns			my $loose; #
661	1	800ns			my $allow_barekey; # bareKey
662
663					# $opt flag
664					# 0x00000001 .... decode_prefix
665					# 0x10000000 .... incr_parse
666
667					sub PP_decode_json {
668					my ($self, $opt); # $opt is an effective flag during this decode_json.
669
670					($self, $text, $opt) = @_;
671
672					($at, $ch, $depth) = (0, '', 0);
673
674					if ( !defined $text or ref $text ) {
675					decode_error("malformed JSON string, neither array, object, number, string or atom");
676					}
677
678					my $idx = $self->{PROPS};
679
680					($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
681					= @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
682
683					if ( $utf8 ) {
684					utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
685					}
686					else {
687					utf8::upgrade( $text );
688					}
689
690					$len = length $text;
691
692					($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
693					= @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
694
695					if ($max_size > 1) {
696	3	2.80ms	2	38µs	# spent 31µs (24+7) within JSON::PP::BEGIN@696 which was called: # once (24µs+7µs) by JSON::_load_pp at line 696 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
1285					sub _decode_surrogates { # from perlunicode
1286					my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
1287					my $un = pack('U*', $uni);
1288					utf8::encode( $un );
1289					return $un;
1290					}
1291
1292
1293					sub _decode_unicode {
1294					my $un = pack('U', hex shift);
1295					utf8::encode( $un );
1296					return $un;
1297					}
1298
- -
1303					###############################
1304					# Utilities
1305					#
1306
1307					# spent 34µs within JSON::PP::BEGIN@1307 which was called: # once (34µs+0s) by JSON::_load_pp at line 1320 BEGIN {
1308	2	32µs			eval 'require Scalar::Util'; # spent 4µs executing statements in string eval
1309					unless($@){
1310					*JSON::PP::blessed = \&Scalar::Util::blessed;
1311					}
1312					else{ # This code is from Sclar::Util.
1313					# warn $@;
1314					eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
1315					*JSON::PP::blessed = sub {
1316					local($@, $SIG{__DIE__}, $SIG{__WARN__});
1317					ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
1318					};
1319					}
1320	1	229µs	1	34µs	} # spent 34µs making 1 call to JSON::PP::BEGIN@1307
1321
1322
1323					# shamely copied and modified from JSON::XS code.
1324
1325	1	35µs			$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
1326	1	1µs			$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1327
1328					sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
1329
1330					sub true { $JSON::PP::true }
1331					sub false { $JSON::PP::false }
1332					sub null { undef; }
1333
1334					###############################
1335
1336					package JSON::PP::Boolean;
1337
1338
1339					# spent 81µs (18+63) within JSON::PP::Boolean::BEGIN@1339 which was called: # once (18µs+63µs) by JSON::_load_pp at line 1344 use overload (
1340					"0+" => sub { ${$_[0]} },
1341					"++" => sub { $_[0] = ${$_[0]} + 1 },
1342					"--" => sub { $_[0] = ${$_[0]} - 1 },
1343			1	63µs	fallback => 1, # spent 63µs making 1 call to overload::import
1344	3	46µs	1	81µs	); # spent 81µs making 1 call to JSON::PP::Boolean::BEGIN@1339
1345
1346
1347					###############################
1348
1349					package JSON::PP::IncrParser;
1350
1351	3	40µs	2	24µs	# spent 18µs (13+5) within JSON::PP::IncrParser::BEGIN@1351 which was called: # once (13µs+5µs) by JSON::_load_pp at line 1351 use strict; # spent 18µs making 1 call to JSON::PP::IncrParser::BEGIN@1351 # spent 5µs making 1 call to strict::import
1352
1353	3	36µs	2	151µs	# spent 81µs (12+70) within JSON::PP::IncrParser::BEGIN@1353 which was called: # once (12µs+70µs) by JSON::_load_pp at line 1353 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
1354	3	30µs	2	75µs	# spent 42µs (8+33) within JSON::PP::IncrParser::BEGIN@1354 which was called: # once (8µs+33µs) by JSON::_load_pp at line 1354 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
1355	3	37µs	2	71µs	# spent 40µs (8+31) within JSON::PP::IncrParser::BEGIN@1355 which was called: # once (8µs+31µs) by JSON::_load_pp at line 1355 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
1356	3	30µs	2	74µs	# spent 42µs (9+32) within JSON::PP::IncrParser::BEGIN@1356 which was called: # once (9µs+32µs) by JSON::_load_pp at line 1356 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
1357	3	27µs	2	69µs	# spent 39µs (8+30) within JSON::PP::IncrParser::BEGIN@1357 which was called: # once (8µs+30µs) by JSON::_load_pp at line 1357 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
1358	3	877µs	2	69µs	# spent 39µs (8+30) within JSON::PP::IncrParser::BEGIN@1358 which was called: # once (8µs+30µs) by JSON::_load_pp at line 1358 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
1360	1	500ns			$JSON::PP::IncrParser::VERSION = '1.01';
1361
1362	1	2µs			my $unpack_format = $] < 5.006 ? 'C' : 'U';
1363
1364					sub new {
1365					my ( $class ) = @_;
1366
1367					bless {
1368					incr_nest => 0,
1369					incr_text => undef,
1370					incr_parsing => 0,
1371					incr_p => 0,
1372					}, $class;
1373					}
1374
1375
1376					sub incr_parse {
1377					my ( $self, $coder, $text ) = @_;
1378
1379					$self->{incr_text} = '' unless ( defined $self->{incr_text} );
1380
1381					if ( defined $text ) {
1382					if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
1383					utf8::upgrade( $self->{incr_text} ) ;
1384					utf8::decode( $self->{incr_text} ) ;
1385					}
1386					$self->{incr_text} .= $text;
1387					}
1388
1389
1390					my $max_size = $coder->get_max_size;
1391
1392					if ( defined wantarray ) {
1393
1394					$self->{incr_mode} = INCR_M_WS;
1395
1396					if ( wantarray ) {
1397					my @ret;
1398
1399					$self->{incr_parsing} = 1;
1400
1401					do {
1402					push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
1403
1404					unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
1405					$self->{incr_mode} = INCR_M_WS;
1406					}
1407
1408					} until ( !$self->{incr_text} );
1409
1410					$self->{incr_parsing} = 0;
1411
1412					return @ret;
1413					}
1414					else { # in scalar context
1415					$self->{incr_parsing} = 1;
1416					my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
1417					$self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
1418					return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
1419					}
1420
1421					}
1422
1423					}
1424
1425
1426					sub _incr_parse {
1427					my ( $self, $coder, $text, $skip ) = @_;
1428					my $p = $self->{incr_p};
1429					my $restore = $p;
1430
1431					my @obj;
1432					my $len = length $text;
1433
1434					if ( $self->{incr_mode} == INCR_M_WS ) {
1435					while ( $len > $p ) {
1436					my $s = substr( $text, $p, 1 );
1437					$p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
1438					$self->{incr_mode} = INCR_M_JSON;
1439					last;
1440					}
1441					}
1442
1443					while ( $len > $p ) {
1444					my $s = substr( $text, $p++, 1 );
1445
1446					if ( $s eq '"' ) {
1447					if ( $self->{incr_mode} != INCR_M_STR ) {
1448					$self->{incr_mode} = INCR_M_STR;
1449					}
1450					else {
1451					$self->{incr_mode} = INCR_M_JSON;
1452					unless ( $self->{incr_nest} ) {
1453					last;
1454					}
1455					}
1456					}
1457
1458					if ( $self->{incr_mode} == INCR_M_JSON ) {
1459
1460					if ( $s eq '[' or $s eq '{' ) {
1461					if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
1462					Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
1463					}
1464					}
1465					elsif ( $s eq ']' or $s eq '}' ) {
1466					last if ( --$self->{incr_nest} <= 0 );
1467					}
1468					elsif ( $s eq '#' ) {
1469					while ( $len > $p ) {
1470					last if substr( $text, $p++, 1 ) eq "\n";
1471					}
1472					}
1473
1474					}
1475
1476					}
1477
1478					$self->{incr_p} = $p;
1479
1480					return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
1481
1482					return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
1483
1484					local $Carp::CarpLevel = 2;
1485
1486					$self->{incr_p} = $restore;
1487					$self->{incr_c} = $p;
1488
1489					my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
1490
1491					$self->{incr_text} = substr( $self->{incr_text}, $p );
1492					$self->{incr_p} = 0;
1493
1494					return $obj or '';
1495					}
1496
1497
1498					sub incr_text {
1499					if ( $_[0]->{incr_parsing} ) {
1500					Carp::croak("incr_text can not be called when the incremental parser already started parsing");
1501					}
1502					$_[0]->{incr_text};
1503					}
1504
1505
1506					sub incr_skip {
1507					my $self = shift;
1508					$self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
1509					$self->{incr_p} = 0;
1510					}
1511
1512
1513					sub incr_reset {
1514					my $self = shift;
1515					$self->{incr_text} = undef;
1516					$self->{incr_p} = 0;
1517					$self->{incr_mode} = 0;
1518					$self->{incr_nest} = 0;
1519					$self->{incr_parsing} = 0;
1520					}
1521
1522					###############################
1523
1524
1525	1	24µs			1;
1526					__END__

					# spent 38µs within JSON::PP::CORE:match which was called 17 times, avg 2µs/call: # 17 times (38µs+0s) by JSON::PP::BEGIN@614 at line 619, avg 2µs/call sub JSON::PP::CORE: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