← Index
NYTProf Performance Profile   « line view »
For t/bug-md-11.t
  Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename/home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/JSON/PP.pm
StatementsExecuted 242 statements in 6.47ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111981µs981µsJSON::PP::::BEGIN@68 JSON::PP::BEGIN@68
111158µs220µsJSON::PP::::BEGIN@12 JSON::PP::BEGIN@12
111100µs109µsJSON::PP::::BEGIN@688 JSON::PP::BEGIN@688
11126µs40µsJSON::PP::::BEGIN@53 JSON::PP::BEGIN@53
11115µs30µsJSON::PP::::BEGIN@26 JSON::PP::BEGIN@26
11111µs24µsJSON::PP::IncrParser::::BEGIN@1493JSON::PP::IncrParser::BEGIN@1493
11111µs11µsJSON::PP::::BEGIN@5 JSON::PP::BEGIN@5
11110µs12µsJSON::PP::::BEGIN@790 JSON::PP::BEGIN@790
1119µs9µsJSON::PP::::BEGIN@9 JSON::PP::BEGIN@9
1116µs7µsJSON::PP::IncrParser::::BEGIN@1547JSON::PP::IncrParser::BEGIN@1547
1116µs18µsJSON::PP::::BEGIN@46 JSON::PP::BEGIN@46
1115µs19µsJSON::PP::::BEGIN@1285 JSON::PP::BEGIN@1285
1115µs19µsJSON::PP::::BEGIN@493 JSON::PP::BEGIN@493
1115µs19µsJSON::PP::::BEGIN@209 JSON::PP::BEGIN@209
1115µs6µsJSON::PP::IncrParser::::BEGIN@1485JSON::PP::IncrParser::BEGIN@1485
1114µs17µsJSON::PP::::BEGIN@1471 JSON::PP::BEGIN@1471
1114µs23µsJSON::PP::::BEGIN@15 JSON::PP::BEGIN@15
1114µs35µsJSON::PP::::BEGIN@25 JSON::PP::BEGIN@25
1114µs6µsJSON::PP::::BEGIN@6 JSON::PP::BEGIN@6
1114µs15µsJSON::PP::::BEGIN@515 JSON::PP::BEGIN@515
1114µs38µsJSON::PP::IncrParser::::BEGIN@1487JSON::PP::IncrParser::BEGIN@1487
1114µs20µsJSON::PP::IncrParser::::BEGIN@1488JSON::PP::IncrParser::BEGIN@1488
1113µs17µsJSON::PP::IncrParser::::BEGIN@1490JSON::PP::IncrParser::BEGIN@1490
1113µs19µsJSON::PP::::BEGIN@39 JSON::PP::BEGIN@39
1113µs18µsJSON::PP::::BEGIN@48 JSON::PP::BEGIN@48
1113µs16µsJSON::PP::IncrParser::::BEGIN@1492JSON::PP::IncrParser::BEGIN@1492
1113µs16µsJSON::PP::IncrParser::::BEGIN@1494JSON::PP::IncrParser::BEGIN@1494
1113µs18µsJSON::PP::::BEGIN@27 JSON::PP::BEGIN@27
1113µs32µsJSON::PP::::BEGIN@29 JSON::PP::BEGIN@29
1113µs15µsJSON::PP::::BEGIN@49 JSON::PP::BEGIN@49
1113µs15µsJSON::PP::::BEGIN@35 JSON::PP::BEGIN@35
1113µs17µsJSON::PP::IncrParser::::BEGIN@1489JSON::PP::IncrParser::BEGIN@1489
1113µs17µsJSON::PP::::BEGIN@38 JSON::PP::BEGIN@38
1113µs16µsJSON::PP::::BEGIN@31 JSON::PP::BEGIN@31
1113µs15µsJSON::PP::::BEGIN@33 JSON::PP::BEGIN@33
1113µs16µsJSON::PP::::BEGIN@45 JSON::PP::BEGIN@45
1112µs17µsJSON::PP::::BEGIN@28 JSON::PP::BEGIN@28
1112µs15µsJSON::PP::::BEGIN@32 JSON::PP::BEGIN@32
1112µs15µsJSON::PP::::BEGIN@36 JSON::PP::BEGIN@36
1112µs18µsJSON::PP::::BEGIN@43 JSON::PP::BEGIN@43
1112µs17µsJSON::PP::IncrParser::::BEGIN@1491JSON::PP::IncrParser::BEGIN@1491
1112µs16µsJSON::PP::::BEGIN@30 JSON::PP::BEGIN@30
1112µs15µsJSON::PP::::BEGIN@41 JSON::PP::BEGIN@41
1112µs15µsJSON::PP::::BEGIN@42 JSON::PP::BEGIN@42
1112µs15µsJSON::PP::::BEGIN@34 JSON::PP::BEGIN@34
1112µs16µsJSON::PP::::BEGIN@40 JSON::PP::BEGIN@40
1112µs2µsJSON::PP::::BEGIN@14 JSON::PP::BEGIN@14
1112µs2µsJSON::PP::::BEGIN@11 JSON::PP::BEGIN@11
1112µs2µsJSON::PP::::BEGIN@62 JSON::PP::BEGIN@62
1111µs1µsJSON::PP::::BEGIN@8 JSON::PP::BEGIN@8
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__[:359] JSON::PP::__ANON__[:359]
0000s0sJSON::PP::::__ANON__[:364] JSON::PP::__ANON__[:364]
0000s0sJSON::PP::::_decode_surrogates JSON::PP::_decode_surrogates
0000s0sJSON::PP::::_decode_unicode JSON::PP::_decode_unicode
0000s0sJSON::PP::::_detect_utf_encoding JSON::PP::_detect_utf_encoding
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::::_looks_like_number JSON::PP::_looks_like_number
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::::boolean_values JSON::PP::boolean_values
0000s0sJSON::PP::::core_bools JSON::PP::core_bools
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_boolean_values JSON::PP::get_boolean_values
0000s0sJSON::PP::::get_core_bools JSON::PP::get_core_bools
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::::get_unblessed_bool JSON::PP::get_unblessed_bool
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::::incr_text JSON::PP::incr_text
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::::new JSON::PP::new
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::::pretty JSON::PP::pretty
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::::tag JSON::PP::tag
0000s0sJSON::PP::::to_json JSON::PP::to_json
0000s0sJSON::PP::::true JSON::PP::true
0000s0sJSON::PP::::unblessed_bool JSON::PP::unblessed_bool
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
5228µs111µs
# spent 11µs within JSON::PP::BEGIN@5 which was called: # once (11µs+0s) by JSON::BEGIN@1 at line 5
use 5.008;
# spent 11µs making 1 call to JSON::PP::BEGIN@5
6214µs27µs
# spent 6µs (4+2) within JSON::PP::BEGIN@6 which was called: # once (4µs+2µs) by JSON::BEGIN@1 at line 6
use strict;
# spent 6µs making 1 call to JSON::PP::BEGIN@6 # spent 2µs making 1 call to strict::import
7
8218µs11µs
# spent 1µs within JSON::PP::BEGIN@8 which was called: # once (1µs+0s) by JSON::BEGIN@1 at line 8
use Exporter ();
# spent 1µs making 1 call to JSON::PP::BEGIN@8
9124µs19µs
# spent 9µs within JSON::PP::BEGIN@9 which was called: # once (9µs+0s) by JSON::BEGIN@1 at line 9
BEGIN { our @ISA = ('Exporter') }
# spent 9µs making 1 call to JSON::PP::BEGIN@9
10
11211µs12µs
# spent 2µs within JSON::PP::BEGIN@11 which was called: # once (2µs+0s) by JSON::BEGIN@1 at line 11
use overload ();
# spent 2µs making 1 call to JSON::PP::BEGIN@11
12272µs2220µs
# spent 220µs (158+62) within JSON::PP::BEGIN@12 which was called: # once (158µs+62µs) by JSON::BEGIN@1 at line 12
use JSON::PP::Boolean;
# spent 220µs making 1 call to JSON::PP::BEGIN@12 # spent 700ns making 1 call to UNIVERSAL::import
13
14213µs12µs
# spent 2µs within JSON::PP::BEGIN@14 which was called: # once (2µs+0s) by JSON::BEGIN@1 at line 14
use Carp ();
# spent 2µs making 1 call to JSON::PP::BEGIN@14
15229µs242µs
# spent 23µs (4+19) within JSON::PP::BEGIN@15 which was called: # once (4µs+19µs) by JSON::BEGIN@1 at line 15
use Scalar::Util qw(blessed reftype refaddr);
# spent 23µs making 1 call to JSON::PP::BEGIN@15 # spent 19µs making 1 call to Exporter::import
16#use Devel::Peek;
17
181400nsour $VERSION = '4.16';
19
2011µsour @EXPORT = qw(encode_json decode_json from_json to_json);
21
22# instead of hash-access, i tried index-access for speed.
23# but this method is not faster than what i expected. so it will be changed.
24
25216µs265µs
# spent 35µs (4+30) within JSON::PP::BEGIN@25 which was called: # once (4µs+30µs) by JSON::BEGIN@1 at line 25
use constant P_ASCII => 0;
# spent 35µs making 1 call to JSON::PP::BEGIN@25 # spent 30µs making 1 call to constant::import
26214µs245µs
# spent 30µs (15+15) within JSON::PP::BEGIN@26 which was called: # once (15µs+15µs) by JSON::BEGIN@1 at line 26
use constant P_LATIN1 => 1;
# spent 30µs making 1 call to JSON::PP::BEGIN@26 # spent 15µs making 1 call to constant::import
27212µs234µs
# spent 18µs (3+15) within JSON::PP::BEGIN@27 which was called: # once (3µs+15µs) by JSON::BEGIN@1 at line 27
use constant P_UTF8 => 2;
# spent 18µs making 1 call to JSON::PP::BEGIN@27 # spent 15µs making 1 call to constant::import
28212µs232µs
# spent 17µs (2+14) within JSON::PP::BEGIN@28 which was called: # once (2µs+14µs) by JSON::BEGIN@1 at line 28
use constant P_INDENT => 3;
# spent 17µs making 1 call to JSON::PP::BEGIN@28 # spent 14µs making 1 call to constant::import
29212µs262µs
# spent 32µs (3+29) within JSON::PP::BEGIN@29 which was called: # once (3µs+29µs) by JSON::BEGIN@1 at line 29
use constant P_CANONICAL => 4;
# spent 32µs making 1 call to JSON::PP::BEGIN@29 # spent 29µs making 1 call to constant::import
30211µs229µs
# spent 16µs (2+14) within JSON::PP::BEGIN@30 which was called: # once (2µs+14µs) by JSON::BEGIN@1 at line 30
use constant P_SPACE_BEFORE => 5;
# spent 16µs making 1 call to JSON::PP::BEGIN@30 # spent 14µs making 1 call to constant::import
31212µs228µs
# spent 16µs (3+13) within JSON::PP::BEGIN@31 which was called: # once (3µs+13µs) by JSON::BEGIN@1 at line 31
use constant P_SPACE_AFTER => 6;
# spent 16µs making 1 call to JSON::PP::BEGIN@31 # spent 13µs making 1 call to constant::import
32212µs228µs
# spent 15µs (2+13) within JSON::PP::BEGIN@32 which was called: # once (2µs+13µs) by JSON::BEGIN@1 at line 32
use constant P_ALLOW_NONREF => 7;
# spent 15µs making 1 call to JSON::PP::BEGIN@32 # spent 13µs making 1 call to constant::import
33211µs227µs
# spent 15µs (3+12) within JSON::PP::BEGIN@33 which was called: # once (3µs+12µs) by JSON::BEGIN@1 at line 33
use constant P_SHRINK => 8;
# spent 15µs making 1 call to JSON::PP::BEGIN@33 # spent 12µs making 1 call to constant::import
34211µs228µs
# spent 15µs (2+13) within JSON::PP::BEGIN@34 which was called: # once (2µs+13µs) by JSON::BEGIN@1 at line 34
use constant P_ALLOW_BLESSED => 9;
# spent 15µs making 1 call to JSON::PP::BEGIN@34 # spent 13µs making 1 call to constant::import
35211µs228µs
# spent 15µs (3+12) within JSON::PP::BEGIN@35 which was called: # once (3µs+12µs) by JSON::BEGIN@1 at line 35
use constant P_CONVERT_BLESSED => 10;
# spent 15µs making 1 call to JSON::PP::BEGIN@35 # spent 12µs making 1 call to constant::import
36220µs228µs
# spent 15µs (2+13) within JSON::PP::BEGIN@36 which was called: # once (2µs+13µs) by JSON::BEGIN@1 at line 36
use constant P_RELAXED => 11;
# spent 15µs making 1 call to JSON::PP::BEGIN@36 # spent 13µs making 1 call to constant::import
37
38227µs232µs
# spent 17µs (3+14) within JSON::PP::BEGIN@38 which was called: # once (3µs+14µs) by JSON::BEGIN@1 at line 38
use constant P_LOOSE => 12;
# spent 17µs making 1 call to JSON::PP::BEGIN@38 # spent 14µs making 1 call to constant::import
39213µs234µs
# spent 19µs (3+16) within JSON::PP::BEGIN@39 which was called: # once (3µs+16µs) by JSON::BEGIN@1 at line 39
use constant P_ALLOW_BIGNUM => 13;
# spent 19µs making 1 call to JSON::PP::BEGIN@39 # spent 16µs making 1 call to constant::import
40211µs230µs
# spent 16µs (2+14) within JSON::PP::BEGIN@40 which was called: # once (2µs+14µs) by JSON::BEGIN@1 at line 40
use constant P_ALLOW_BAREKEY => 14;
# spent 16µs making 1 call to JSON::PP::BEGIN@40 # spent 14µs making 1 call to constant::import
41211µs228µs
# spent 15µs (2+13) within JSON::PP::BEGIN@41 which was called: # once (2µs+13µs) by JSON::BEGIN@1 at line 41
use constant P_ALLOW_SINGLEQUOTE => 15;
# spent 15µs making 1 call to JSON::PP::BEGIN@41 # spent 13µs making 1 call to constant::import
42211µs227µs
# spent 15µs (2+12) within JSON::PP::BEGIN@42 which was called: # once (2µs+12µs) by JSON::BEGIN@1 at line 42
use constant P_ESCAPE_SLASH => 16;
# spent 15µs making 1 call to JSON::PP::BEGIN@42 # spent 12µs making 1 call to constant::import
43216µs234µs
# spent 18µs (2+16) within JSON::PP::BEGIN@43 which was called: # once (2µs+16µs) by JSON::BEGIN@1 at line 43
use constant P_AS_NONBLESSED => 17;
# spent 18µs making 1 call to JSON::PP::BEGIN@43 # spent 16µs making 1 call to constant::import
44
45211µs229µs
# spent 16µs (3+13) within JSON::PP::BEGIN@45 which was called: # once (3µs+13µs) by JSON::BEGIN@1 at line 45
use constant P_ALLOW_UNKNOWN => 18;
# spent 16µs making 1 call to JSON::PP::BEGIN@45 # spent 13µs making 1 call to constant::import
46219µs231µs
# spent 18µs (6+13) within JSON::PP::BEGIN@46 which was called: # once (6µs+13µs) by JSON::BEGIN@1 at line 46
use constant P_ALLOW_TAGS => 19;
# spent 18µs making 1 call to JSON::PP::BEGIN@46 # spent 13µs making 1 call to constant::import
47
48217µs233µs
# spent 18µs (3+15) within JSON::PP::BEGIN@48 which was called: # once (3µs+15µs) by JSON::BEGIN@1 at line 48
use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0;
# spent 18µs making 1 call to JSON::PP::BEGIN@48 # spent 15µs making 1 call to constant::import
49264µs228µs
# spent 15µs (3+12) within JSON::PP::BEGIN@49 which was called: # once (3µs+12µs) by JSON::BEGIN@1 at line 49
use constant CORE_BOOL => defined &builtin::is_bool;
# spent 15µs making 1 call to JSON::PP::BEGIN@49 # spent 12µs making 1 call to constant::import
50
511100nsmy $invalid_char_re;
52
53
# spent 40µs (26+15) within JSON::PP::BEGIN@53 which was called: # once (26µs+15µs) by JSON::BEGIN@1 at line 60
BEGIN {
541400ns $invalid_char_re = "[";
551700ns for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok
563413µs $invalid_char_re .= quotemeta chr utf8::unicode_to_native($i);
57 }
58
59126µs215µs $invalid_char_re = qr/$invalid_char_re]/;
# spent 14µs making 1 call to CORE::regcomp # spent 1µs making 1 call to CORE::qr
60125µs140µs}
# spent 40µs making 1 call to JSON::PP::BEGIN@53
61
62
# spent 2µs within JSON::PP::BEGIN@62 which was called: # once (2µs+0s) by JSON::BEGIN@1 at line 66
BEGIN {
6312µs if (USE_B) {
64 require B;
65 }
66164µs12µs}
# spent 2µs making 1 call to JSON::PP::BEGIN@62
67
68
# spent 981µs within JSON::PP::BEGIN@68 which was called: # once (981µs+0s) by JSON::BEGIN@1 at line 102
BEGIN {
6911µs my @xs_compati_bit_properties = qw(
70 latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
71 allow_blessed convert_blessed relaxed allow_unknown
72 allow_tags
73 );
741500ns my @pp_bit_properties = qw(
75 allow_singlequote allow_bignum loose
76 allow_barekey escape_slash as_nonblessed
77 );
78
7915µs for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
80207µs my $property_id = 'P_' . uc($name);
81
8220969µs eval qq/
# spent 0s executing statements in string eval
83 sub $name {
84 my \$enable = defined \$_[1] ? \$_[1] : 1;
85
86 if (\$enable) {
87 \$_[0]->{PROPS}->[$property_id] = 1;
88 }
89 else {
90 \$_[0]->{PROPS}->[$property_id] = 0;
91 }
92
93 \$_[0];
94 }
95
96 sub get_$name {
97 \$_[0]->{PROPS}->[$property_id] ? 1 : '';
98 }
99 /;
100 }
101
1021245µs1981µs}
# spent 981µs making 1 call to JSON::PP::BEGIN@68
103
- -
106# Functions
107
108my $JSON; # cache
109
110sub encode_json ($) { # encode
111 ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
112}
113
114
115sub decode_json { # decode
116 ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
117}
118
119# Obsoleted
120
121sub to_json($) {
122 Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
123}
124
125
126sub from_json($) {
127 Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
128}
129
130
131# Methods
132
133sub new {
134 my $class = shift;
135 my $self = {
136 max_depth => 512,
137 max_size => 0,
138 indent_length => 3,
139 };
140
141 $self->{PROPS}[P_ALLOW_NONREF] = 1;
142
143 bless $self, $class;
144}
145
146
147sub encode {
148 return $_[0]->PP_encode_json($_[1]);
149}
150
151
152sub decode {
153 return $_[0]->PP_decode_json($_[1], 0x00000000);
154}
155
156
157sub decode_prefix {
158 return $_[0]->PP_decode_json($_[1], 0x00000001);
159}
160
161
162# accessor
163
164
165# pretty printing
166
167sub pretty {
168 my ($self, $v) = @_;
169 my $enable = defined $v ? $v : 1;
170
171 if ($enable) { # indent_length(3) for JSON::XS compatibility
172 $self->indent(1)->space_before(1)->space_after(1);
173 }
174 else {
175 $self->indent(0)->space_before(0)->space_after(0);
176 }
177
178 $self;
179}
180
181# etc
182
183sub max_depth {
184 my $max = defined $_[1] ? $_[1] : 0x80000000;
185 $_[0]->{max_depth} = $max;
186 $_[0];
187}
188
189
190sub get_max_depth { $_[0]->{max_depth}; }
191
192
193sub max_size {
194 my $max = defined $_[1] ? $_[1] : 0;
195 $_[0]->{max_size} = $max;
196 $_[0];
197}
198
199
200sub get_max_size { $_[0]->{max_size}; }
201
202sub boolean_values {
203 my $self = shift;
204 if (@_) {
205 my ($false, $true) = @_;
206 $self->{false} = $false;
207 $self->{true} = $true;
208 if (CORE_BOOL) {
2091866µs233µs
# spent 19µs (5+14) within JSON::PP::BEGIN@209 which was called: # once (5µs+14µs) by JSON::BEGIN@1 at line 209
BEGIN { CORE_BOOL and warnings->unimport(qw(experimental::builtin)) }
# spent 19µs making 1 call to JSON::PP::BEGIN@209 # spent 14µs making 1 call to warnings::unimport
210 if (builtin::is_bool($true) && builtin::is_bool($false) && $true && !$false) {
211 $self->{core_bools} = !!1;
212 }
213 else {
214 delete $self->{core_bools};
215 }
216 }
217 } else {
218 delete $self->{false};
219 delete $self->{true};
220 delete $self->{core_bools};
221 }
222 return $self;
223}
224
225sub core_bools {
226 my $self = shift;
227 my $core_bools = defined $_[0] ? $_[0] : 1;
228 if ($core_bools) {
229 $self->{true} = !!1;
230 $self->{false} = !!0;
231 $self->{core_bools} = !!1;
232 }
233 else {
234 $self->{true} = $JSON::PP::true;
235 $self->{false} = $JSON::PP::false;
236 $self->{core_bools} = !!0;
237 }
238 return $self;
239}
240
241sub get_core_bools {
242 my $self = shift;
243 return !!$self->{core_bools};
244}
245
246sub unblessed_bool {
247 my $self = shift;
248 return $self->core_bools(@_);
249}
250
251sub get_unblessed_bool {
252 my $self = shift;
253 return $self->get_core_bools(@_);
254}
255
256sub get_boolean_values {
257 my $self = shift;
258 if (exists $self->{true} and exists $self->{false}) {
259 return @$self{qw/false true/};
260 }
261 return;
262}
263
264sub filter_json_object {
265 if (defined $_[1] and ref $_[1] eq 'CODE') {
266 $_[0]->{cb_object} = $_[1];
267 } else {
268 delete $_[0]->{cb_object};
269 }
270 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
271 $_[0];
272}
273
274sub filter_json_single_key_object {
275 if (@_ == 1 or @_ > 3) {
276 Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)");
277 }
278 if (defined $_[2] and ref $_[2] eq 'CODE') {
279 $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
280 } else {
281 delete $_[0]->{cb_sk_object}->{$_[1]};
282 delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}};
283 }
284 $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
285 $_[0];
286}
287
288sub indent_length {
289 if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
290 Carp::carp "The acceptable range of indent_length() is 0 to 15.";
291 }
292 else {
293 $_[0]->{indent_length} = $_[1];
294 }
295 $_[0];
296}
297
298sub get_indent_length {
299 $_[0]->{indent_length};
300}
301
302sub sort_by {
303 $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
304 $_[0];
305}
306
307sub allow_bigint {
308 Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");
309 $_[0]->allow_bignum;
310}
311
312###############################
313
314###
315### Perl => JSON
316###
317
318
319{ # Convert
320
3211100ns my $max_depth;
322 my $indent;
323 my $ascii;
324 my $latin1;
325 my $utf8;
326 my $space_before;
327 my $space_after;
328 my $canonical;
329 my $allow_blessed;
330 my $convert_blessed;
331
332 my $indent_length;
333 my $escape_slash;
334 my $bignum;
335 my $as_nonblessed;
336 my $allow_tags;
337
338 my $depth;
339 my $indent_count;
340 my $keysort;
341
342
343 sub PP_encode_json {
344 my $self = shift;
345 my $obj = shift;
346
347 $indent_count = 0;
348 $depth = 0;
349
350 my $props = $self->{PROPS};
351
352 ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
353 $convert_blessed, $escape_slash, $bignum, $as_nonblessed, $allow_tags)
354 = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
355 P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED, P_ALLOW_TAGS];
356
357 ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
358
359 $keysort = $canonical ? sub { $a cmp $b } : undef;
360
361 if ($self->{sort_by}) {
362 $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
363 : $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
364 : sub { $a cmp $b };
365 }
366
367 encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
368 if(!ref $obj and !$props->[ P_ALLOW_NONREF ]);
369
370 my $str = $self->object_to_json($obj);
371
372 $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
373
374 return $str;
375 }
376
377
378 sub object_to_json {
379 my ($self, $obj) = @_;
380 my $type = ref($obj);
381
382 if($type eq 'HASH'){
383 return $self->hash_to_json($obj);
384 }
385 elsif($type eq 'ARRAY'){
386 return $self->array_to_json($obj);
387 }
388 elsif ($type) { # blessed object?
389 if (blessed($obj)) {
390
391 return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
392
393 if ( $allow_tags and $obj->can('FREEZE') ) {
394 my $obj_class = ref $obj || $obj;
395 $obj = bless $obj, $obj_class;
396 my @results = $obj->FREEZE('JSON');
397 if ( @results and ref $results[0] ) {
398 if ( refaddr( $obj ) eq refaddr( $results[0] ) ) {
399 encode_error( sprintf(
400 "%s::FREEZE method returned same object as was passed instead of a new one",
401 ref $obj
402 ) );
403 }
404 }
405 return '("'.$obj_class.'")['.join(',', @results).']';
406 }
407
408 if ( $convert_blessed and $obj->can('TO_JSON') ) {
409 my $result = $obj->TO_JSON();
410 if ( defined $result and ref( $result ) ) {
411 if ( refaddr( $obj ) eq refaddr( $result ) ) {
412 encode_error( sprintf(
413 "%s::TO_JSON method returned same object as was passed instead of a new one",
414 ref $obj
415 ) );
416 }
417 }
418
419 return $self->object_to_json( $result );
420 }
421
422 return "$obj" if ( $bignum and _is_bignum($obj) );
423
424 if ($allow_blessed) {
425 return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed.
426 return 'null';
427 }
428 encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj)
429 );
430 }
431 else {
432 return $self->value_to_json($obj);
433 }
434 }
435 else{
436 return $self->value_to_json($obj);
437 }
438 }
439
440
441 sub hash_to_json {
442 my ($self, $obj) = @_;
443 my @res;
444
445 encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
446 if (++$depth > $max_depth);
447
448 my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
449 my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
450
451 for my $k ( _sort( $obj ) ) {
452 push @res, $self->string_to_json( $k )
453 . $del
454 . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) );
455 }
456
457 --$depth;
458 $self->_down_indent() if ($indent);
459
460 return '{}' unless @res;
461 return '{' . $pre . join( ",$pre", @res ) . $post . '}';
462 }
463
464
465 sub array_to_json {
466 my ($self, $obj) = @_;
467 my @res;
468
469 encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
470 if (++$depth > $max_depth);
471
472 my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
473
474 for my $v (@$obj){
475 push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v);
476 }
477
478 --$depth;
479 $self->_down_indent() if ($indent);
480
481 return '[]' unless @res;
482 return '[' . $pre . join( ",$pre", @res ) . $post . ']';
483 }
484
485 sub _looks_like_number {
486 my $value = shift;
487 if (USE_B) {
488 my $b_obj = B::svref_2object(\$value);
489 my $flags = $b_obj->FLAGS;
490 return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
491 return;
492 } else {
493278µs233µs
# spent 19µs (5+14) within JSON::PP::BEGIN@493 which was called: # once (5µs+14µs) by JSON::BEGIN@1 at line 493
no warnings 'numeric';
# spent 19µs making 1 call to JSON::PP::BEGIN@493 # spent 14µs making 1 call to warnings::unimport
494 # if the utf8 flag is on, it almost certainly started as a string
495 return if utf8::is_utf8($value);
496 # detect numbers
497 # string & "" -> ""
498 # number & "" -> 0 (with warning)
499 # nan and inf can detect as numbers, so check with * 0
500 return unless length((my $dummy = "") & $value);
501 return unless 0 + $value eq $value;
502 return 1 if $value * 0 == 0;
503 return -1; # inf/nan
504 }
505 }
506
507 sub value_to_json {
508 my ($self, $value) = @_;
509
510 return 'null' if(!defined $value);
511
512 my $type = ref($value);
513
514 if (!$type) {
5151539µs226µs
# spent 15µs (4+11) within JSON::PP::BEGIN@515 which was called: # once (4µs+11µs) by JSON::BEGIN@1 at line 515
BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
# spent 15µs making 1 call to JSON::PP::BEGIN@515 # spent 11µs making 1 call to warnings::unimport
516 if (CORE_BOOL && builtin::is_bool($value)) {
517 return $value ? 'true' : 'false';
518 }
519 elsif (_looks_like_number($value)) {
520 return $value;
521 }
522 return $self->string_to_json($value);
523 }
524 elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
525 return $$value == 1 ? 'true' : 'false';
526 }
527 else {
528 if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
529 return $self->value_to_json("$value");
530 }
531
532 if ($type eq 'SCALAR' and defined $$value) {
533 return $$value eq '1' ? 'true'
534 : $$value eq '0' ? 'false'
535 : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
536 : encode_error("cannot encode reference to scalar");
537 }
538
539 if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
540 return 'null';
541 }
542 else {
543 if ( $type eq 'SCALAR' or $type eq 'REF' ) {
544 encode_error("cannot encode reference to scalar");
545 }
546 else {
547 encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
548 }
549 }
550
551 }
552 }
553
554
55513µs my %esc = (
556 "\n" => '\n',
557 "\r" => '\r',
558 "\t" => '\t',
559 "\f" => '\f',
560 "\b" => '\b',
561 "\"" => '\"',
562 "\\" => '\\\\',
563 "\'" => '\\\'',
564 );
565
566
567 sub string_to_json {
568 my ($self, $arg) = @_;
569
570 $arg =~ s/(["\\\n\r\t\f\b])/$esc{$1}/g;
571 $arg =~ s/\//\\\//g if ($escape_slash);
572
573 # On ASCII platforms, matches [\x00-\x08\x0b\x0e-\x1f]
574 $arg =~ s/([^\n\t\c?[:^cntrl:][:^ascii:]])/'\\u00' . unpack('H2', $1)/eg;
575
576 if ($ascii) {
577 $arg = _encode_ascii($arg);
578 }
579
580 if ($latin1) {
581 $arg = _encode_latin1($arg);
582 }
583
584 if ($utf8) {
585 utf8::encode($arg);
586 }
587
588 return '"' . $arg . '"';
589 }
590
591
592 sub blessed_to_json {
593 my $reftype = reftype($_[1]) || '';
594 if ($reftype eq 'HASH') {
595 return $_[0]->hash_to_json($_[1]);
596 }
597 elsif ($reftype eq 'ARRAY') {
598 return $_[0]->array_to_json($_[1]);
599 }
600 else {
601 return 'null';
602 }
603 }
604
605
606 sub encode_error {
607 my $error = shift;
608 Carp::croak "$error";
609 }
610
611
612 sub _sort {
613 defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
614 }
615
616
617 sub _up_indent {
618 my $self = shift;
619 my $space = ' ' x $indent_length;
620
621 my ($pre,$post) = ('','');
622
623 $post = "\n" . $space x $indent_count;
624
625 $indent_count++;
626
627 $pre = "\n" . $space x $indent_count;
628
629 return ($pre,$post);
630 }
631
632
633 sub _down_indent { $indent_count--; }
634
635
636 sub PP_encode_box {
637 {
638 depth => $depth,
639 indent_count => $indent_count,
640 };
641 }
642
643} # Convert
644
645
6461200nssub _encode_ascii {
647 join('',
648 map {
649 chr($_) =~ /[[:ascii:]]/ ?
650 chr($_) :
651 $_ <= 65535 ?
652 sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
653 } unpack('U*', $_[0])
654 );
655}
656
657
658sub _encode_latin1 {
659 join('',
660 map {
661 $_ <= 255 ?
662 chr($_) :
663 $_ <= 65535 ?
664 sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
665 } unpack('U*', $_[0])
666 );
667}
668
669
670sub _encode_surrogates { # from perlunicode
671 my $uni = $_[0] - 0x10000;
672 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
673}
674
675
676sub _is_bignum {
677 $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
678}
679
- -
682#
683# JSON => Perl
684#
685
6861200nsmy $max_intsize;
687
688
# spent 109µs (100+9) within JSON::PP::BEGIN@688 which was called: # once (100µs+9µs) by JSON::BEGIN@1 at line 698
BEGIN {
6891200ns my $checkint = 1111;
6901800ns for my $d (5..64) {
691171µs $checkint .= 1;
6921767µs my $int = eval qq| $checkint |;
# spent 2µs executing statements in string eval # spent 800ns executing statements in string eval # spent 700ns executing statements in string eval # spent 600ns executing statements in string eval # spent 600ns executing statements in string eval # spent 600ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 500ns executing statements in string eval # spent 400ns executing statements in string eval # spent 400ns executing statements in string eval
6931726µs179µs if ($int =~ /[eE]/) {
# spent 9µs making 17 calls to CORE::match, avg 524ns/call
6941200ns $max_intsize = $d - 1;
69513µs last;
696 }
697 }
6981222µs1109µs}
# spent 109µs making 1 call to JSON::PP::BEGIN@688
699
700{ # PARSE
701
70212µs my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
703 b => "\b",
704 t => "\t",
705 n => "\n",
706 f => "\f",
707 r => "\r",
708 '\\' => '\\',
709 '"' => '"',
710 '/' => '/',
711 );
712
7131100ns my $text; # json data
714 my $at; # offset
715 my $ch; # first character
716 my $len; # text length (changed according to UTF8 or NON UTF8)
717 # INTERNAL
718 my $depth; # nest counter
719 my $encoding; # json text encoding
720 my $is_valid_utf8; # temp variable
721 my $utf8_len; # utf8 byte length
722 # FLAGS
723 my $utf8; # must be utf8
724 my $max_depth; # max nest number of objects and arrays
725 my $max_size;
726 my $relaxed;
727 my $cb_object;
728 my $cb_sk_object;
729
730 my $F_HOOK;
731
732 my $allow_bignum; # using Math::BigInt/BigFloat
733 my $singlequote; # loosely quoting
734 my $loose; #
735 my $allow_barekey; # bareKey
736 my $allow_tags;
737
738 my $alt_true;
739 my $alt_false;
740
741 sub _detect_utf_encoding {
742 my $text = shift;
743 my @octets = unpack('C4', $text);
744 return 'unknown' unless defined $octets[3];
745 return ( $octets[0] and $octets[1]) ? 'UTF-8'
746 : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
747 : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
748 : ( $octets[2] ) ? 'UTF-16LE'
749 : (!$octets[2] ) ? 'UTF-32LE'
750 : 'unknown';
751 }
752
753 sub PP_decode_json {
754 my ($self, $want_offset);
755
756 ($self, $text, $want_offset) = @_;
757
758 ($at, $ch, $depth) = (0, '', 0);
759
760 if ( !defined $text or ref $text ) {
761 decode_error("malformed JSON string, neither array, object, number, string or atom");
762 }
763
764 my $props = $self->{PROPS};
765
766 ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote, $allow_tags)
767 = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE, P_ALLOW_TAGS];
768
769 ($alt_true, $alt_false) = @$self{qw/true false/};
770
771 if ( $utf8 ) {
772 $encoding = _detect_utf_encoding($text);
773 if ($encoding ne 'UTF-8' and $encoding ne 'unknown') {
774 require Encode;
775 Encode::from_to($text, $encoding, 'utf-8');
776 } else {
777 utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
778 }
779 }
780 else {
781 utf8::encode( $text );
782 }
783
784 $len = length $text;
785
786 ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
787 = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
788
789 if ($max_size > 1) {
79021.35ms215µs
# spent 12µs (10+2) within JSON::PP::BEGIN@790 which was called: # once (10µs+2µs) by JSON::BEGIN@1 at line 790
use bytes;
# spent 12µs making 1 call to JSON::PP::BEGIN@790 # spent 2µs making 1 call to bytes::import
791 my $bytes = length $text;
792 decode_error(
793 sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
794 , $bytes, $max_size), 1
795 ) if ($bytes > $max_size);
796 }
797
798 white(); # remove head white space
799
800 decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure?
801
802 my $result = value();
803
804 if ( !$props->[ P_ALLOW_NONREF ] and !ref $result ) {
805 decode_error(
806 'JSON text must be an object or array (but found number, string, true, false or null,'
807 . ' use allow_nonref to allow this)', 1);
808 }
809
810 Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
811
812 my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
813
814 white(); # remove tail white space
815
816 return ( $result, $consumed ) if $want_offset; # all right if decode_prefix
817
818 decode_error("garbage after JSON object") if defined $ch;
819
820 $result;
821 }
822
823
824 sub next_chr {
825 return $ch = undef if($at >= $len);
826 $ch = substr($text, $at++, 1);
827 }
828
829
830 sub value {
831 white();
832 return if(!defined $ch);
833 return object() if($ch eq '{');
834 return array() if($ch eq '[');
835 return tag() if($ch eq '(');
836 return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
837 return number() if($ch =~ /[0-9]/ or $ch eq '-');
838 return word();
839 }
840
841 sub string {
842 my $utf16;
843 my $is_utf8;
844
845 ($is_valid_utf8, $utf8_len) = ('', 0);
846
847 my $s = ''; # basically UTF8 flag on
848
849 if($ch eq '"' or ($singlequote and $ch eq "'")){
850 my $boundChar = $ch;
851
852 OUTER: while( defined(next_chr()) ){
853
854 if($ch eq $boundChar){
855 next_chr();
856
857 if ($utf16) {
858 decode_error("missing low surrogate character in surrogate pair");
859 }
860
861 utf8::decode($s) if($is_utf8);
862
863 return $s;
864 }
865 elsif($ch eq '\\'){
866 next_chr();
867 if(exists $escapes{$ch}){
868 $s .= $escapes{$ch};
869 }
870 elsif($ch eq 'u'){ # UNICODE handling
871 my $u = '';
872
873 for(1..4){
874 $ch = next_chr();
875 last OUTER if($ch !~ /[0-9a-fA-F]/);
876 $u .= $ch;
877 }
878
879 # U+D800 - U+DBFF
880 if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
881 $utf16 = $u;
882 }
883 # U+DC00 - U+DFFF
884 elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
885 unless (defined $utf16) {
886 decode_error("missing high surrogate character in surrogate pair");
887 }
888 $is_utf8 = 1;
889 $s .= _decode_surrogates($utf16, $u) || next;
890 $utf16 = undef;
891 }
892 else {
893 if (defined $utf16) {
894 decode_error("surrogate pair expected");
895 }
896
897 my $hex = hex( $u );
898 if ( chr $u =~ /[[:^ascii:]]/ ) {
899 $is_utf8 = 1;
900 $s .= _decode_unicode($u) || next;
901 }
902 else {
903 $s .= chr $hex;
904 }
905 }
906
907 }
908 else{
909 unless ($loose) {
910 $at -= 2;
911 decode_error('illegal backslash escape sequence in string');
912 }
913 $s .= $ch;
914 }
915 }
916 else{
917
918 if ( $ch =~ /[[:^ascii:]]/ ) {
919 unless( $ch = is_valid_utf8($ch) ) {
920 $at -= 1;
921 decode_error("malformed UTF-8 character in JSON string");
922 }
923 else {
924 $at += $utf8_len - 1;
925 }
926
927 $is_utf8 = 1;
928 }
929
930 if (!$loose) {
931 if ($ch =~ $invalid_char_re) { # '/' ok
932 if (!$relaxed or $ch ne "\t") {
933 $at--;
934 decode_error(sprintf "invalid character 0x%X"
935 . " encountered while parsing JSON string",
936 ord $ch);
937 }
938 }
939 }
940
941 $s .= $ch;
942 }
943 }
944 }
945
946 decode_error("unexpected end of string while parsing JSON string");
947 }
948
949
950 sub white {
951 while( defined $ch ){
952 if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){
953 next_chr();
954 }
955 elsif($relaxed and $ch eq '/'){
956 next_chr();
957 if(defined $ch and $ch eq '/'){
958 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
959 }
960 elsif(defined $ch and $ch eq '*'){
961 next_chr();
962 while(1){
963 if(defined $ch){
964 if($ch eq '*'){
965 if(defined(next_chr()) and $ch eq '/'){
966 next_chr();
967 last;
968 }
969 }
970 else{
971 next_chr();
972 }
973 }
974 else{
975 decode_error("Unterminated comment");
976 }
977 }
978 next;
979 }
980 else{
981 $at--;
982 decode_error("malformed JSON string, neither array, object, number, string or atom");
983 }
984 }
985 else{
986 if ($relaxed and $ch eq '#') { # correctly?
987 pos($text) = $at;
988 $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
989 $at = pos($text);
990 next_chr;
991 next;
992 }
993
994 last;
995 }
996 }
997 }
998
999
1000 sub array {
1001 my $a = $_[0] || []; # you can use this code to use another array ref object.
1002
1003 decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
1004 if (++$depth > $max_depth);
1005
1006 next_chr();
1007 white();
1008
1009 if(defined $ch and $ch eq ']'){
1010 --$depth;
1011 next_chr();
1012 return $a;
1013 }
1014 else {
1015 while(defined($ch)){
1016 push @$a, value();
1017
1018 white();
1019
1020 if (!defined $ch) {
1021 last;
1022 }
1023
1024 if($ch eq ']'){
1025 --$depth;
1026 next_chr();
1027 return $a;
1028 }
1029
1030 if($ch ne ','){
1031 last;
1032 }
1033
1034 next_chr();
1035 white();
1036
1037 if ($relaxed and $ch eq ']') {
1038 --$depth;
1039 next_chr();
1040 return $a;
1041 }
1042
1043 }
1044 }
1045
1046 $at-- if defined $ch and $ch ne '';
1047 decode_error(", or ] expected while parsing array");
1048 }
1049
1050 sub tag {
1051 decode_error('malformed JSON string, neither array, object, number, string or atom') unless $allow_tags;
1052
1053 next_chr();
1054 white();
1055
1056 my $tag = value();
1057 return unless defined $tag;
1058 decode_error('malformed JSON string, (tag) must be a string') if ref $tag;
1059
1060 white();
1061
1062 if (!defined $ch or $ch ne ')') {
1063 decode_error(') expected after tag');
1064 }
1065
1066 next_chr();
1067 white();
1068
1069 my $val = value();
1070 return unless defined $val;
1071 decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY';
1072
1073 if (!eval { $tag->can('THAW') }) {
1074 decode_error('cannot decode perl-object (package does not exist)') if $@;
1075 decode_error('cannot decode perl-object (package does not have a THAW method)');
1076 }
1077 $tag->THAW('JSON', @$val);
1078 }
1079
1080 sub object {
1081 my $o = $_[0] || {}; # you can use this code to use another hash ref object.
1082 my $k;
1083
1084 decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
1085 if (++$depth > $max_depth);
1086 next_chr();
1087 white();
1088
1089 if(defined $ch and $ch eq '}'){
1090 --$depth;
1091 next_chr();
1092 if ($F_HOOK) {
1093 return _json_object_hook($o);
1094 }
1095 return $o;
1096 }
1097 else {
1098 while (defined $ch) {
1099 $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
1100 white();
1101
1102 if(!defined $ch or $ch ne ':'){
1103 $at--;
1104 decode_error("':' expected");
1105 }
1106
1107 next_chr();
1108 $o->{$k} = value();
1109 white();
1110
1111 last if (!defined $ch);
1112
1113 if($ch eq '}'){
1114 --$depth;
1115 next_chr();
1116 if ($F_HOOK) {
1117 return _json_object_hook($o);
1118 }
1119 return $o;
1120 }
1121
1122 if($ch ne ','){
1123 last;
1124 }
1125
1126 next_chr();
1127 white();
1128
1129 if ($relaxed and $ch eq '}') {
1130 --$depth;
1131 next_chr();
1132 if ($F_HOOK) {
1133 return _json_object_hook($o);
1134 }
1135 return $o;
1136 }
1137
1138 }
1139
1140 }
1141
1142 $at-- if defined $ch and $ch ne '';
1143 decode_error(", or } expected while parsing object/hash");
1144 }
1145
1146
1147 sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
1148 my $key;
1149 while($ch =~ /[\$\w[:^ascii:]]/){
1150 $key .= $ch;
1151 next_chr();
1152 }
1153 return $key;
1154 }
1155
1156
1157 sub word {
1158 my $word = substr($text,$at-1,4);
1159
1160 if($word eq 'true'){
1161 $at += 3;
1162 next_chr;
1163 return defined $alt_true ? $alt_true : $JSON::PP::true;
1164 }
1165 elsif($word eq 'null'){
1166 $at += 3;
1167 next_chr;
1168 return undef;
1169 }
1170 elsif($word eq 'fals'){
1171 $at += 3;
1172 if(substr($text,$at,1) eq 'e'){
1173 $at++;
1174 next_chr;
1175 return defined $alt_false ? $alt_false : $JSON::PP::false;
1176 }
1177 }
1178
1179 $at--; # for decode_error report
1180
1181 decode_error("'null' expected") if ($word =~ /^n/);
1182 decode_error("'true' expected") if ($word =~ /^t/);
1183 decode_error("'false' expected") if ($word =~ /^f/);
1184 decode_error("malformed JSON string, neither array, object, number, string or atom");
1185 }
1186
1187
1188 sub number {
1189 my $n = '';
1190 my $v;
1191 my $is_dec;
1192 my $is_exp;
1193
1194 if($ch eq '-'){
1195 $n = '-';
1196 next_chr;
1197 if (!defined $ch or $ch !~ /\d/) {
1198 decode_error("malformed number (no digits after initial minus)");
1199 }
1200 }
1201
1202 # According to RFC4627, hex or oct digits are invalid.
1203 if($ch eq '0'){
1204 my $peek = substr($text,$at,1);
1205 if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential)
1206 decode_error("malformed number (leading zero must not be followed by another digit)");
1207 }
1208 $n .= $ch;
1209 next_chr;
1210 }
1211
1212 while(defined $ch and $ch =~ /\d/){
1213 $n .= $ch;
1214 next_chr;
1215 }
1216
1217 if(defined $ch and $ch eq '.'){
1218 $n .= '.';
1219 $is_dec = 1;
1220
1221 next_chr;
1222 if (!defined $ch or $ch !~ /\d/) {
1223 decode_error("malformed number (no digits after decimal point)");
1224 }
1225 else {
1226 $n .= $ch;
1227 }
1228
1229 while(defined(next_chr) and $ch =~ /\d/){
1230 $n .= $ch;
1231 }
1232 }
1233
1234 if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
1235 $n .= $ch;
1236 $is_exp = 1;
1237 next_chr;
1238
1239 if(defined($ch) and ($ch eq '+' or $ch eq '-')){
1240 $n .= $ch;
1241 next_chr;
1242 if (!defined $ch or $ch =~ /\D/) {
1243 decode_error("malformed number (no digits after exp sign)");
1244 }
1245 $n .= $ch;
1246 }
1247 elsif(defined($ch) and $ch =~ /\d/){
1248 $n .= $ch;
1249 }
1250 else {
1251 decode_error("malformed number (no digits after exp sign)");
1252 }
1253
1254 while(defined(next_chr) and $ch =~ /\d/){
1255 $n .= $ch;
1256 }
1257
1258 }
1259
1260 $v .= $n;
1261
1262 if ($is_dec or $is_exp) {
1263 if ($allow_bignum) {
1264 require Math::BigFloat;
1265 return Math::BigFloat->new($v);
1266 }
1267 } else {
1268 if (length $v > $max_intsize) {
1269 if ($allow_bignum) { # from Adam Sussman
1270 require Math::BigInt;
1271 return Math::BigInt->new($v);
1272 }
1273 else {
1274 return "$v";
1275 }
1276 }
1277 }
1278
1279 return $is_dec ? $v/1.0 : 0+$v;
1280 }
1281
1282 # Compute how many bytes are in the longest legal official Unicode
1283 # character
12841400ns my $max_unicode_length = do {
12852482µs232µs
# spent 19µs (5+13) within JSON::PP::BEGIN@1285 which was called: # once (5µs+13µs) by JSON::BEGIN@1 at line 1285
no warnings 'utf8';
# spent 19µs making 1 call to JSON::PP::BEGIN@1285 # spent 13µs making 1 call to warnings::unimport
12861200ns chr 0x10FFFF;
1287 };
128815µs1800ns utf8::encode($max_unicode_length);
# spent 800ns making 1 call to utf8::encode
12891800ns $max_unicode_length = length $max_unicode_length;
1290
1291 sub is_valid_utf8 {
1292
1293 # Returns undef (setting $utf8_len to 0) unless the next bytes in $text
1294 # comprise a well-formed UTF-8 encoded character, in which case,
1295 # return those bytes, setting $utf8_len to their count.
1296
1297 my $start_point = substr($text, $at - 1);
1298
1299 # Look no further than the maximum number of bytes in a single
1300 # character
1301 my $limit = $max_unicode_length;
1302 $limit = length($start_point) if $limit > length($start_point);
1303
1304 # Find the number of bytes comprising the first character in $text
1305 # (without having to know the details of its internal representation).
1306 # This loop will iterate just once on well-formed input.
1307 while ($limit > 0) { # Until we succeed or exhaust the input
1308 my $copy = substr($start_point, 0, $limit);
1309
1310 # decode() will return true if all bytes are valid; false
1311 # if any aren't.
1312 if (utf8::decode($copy)) {
1313
1314 # Is valid: get the first character, convert back to bytes,
1315 # and return those bytes.
1316 $copy = substr($copy, 0, 1);
1317 utf8::encode($copy);
1318 $utf8_len = length $copy;
1319 return substr($start_point, 0, $utf8_len);
1320 }
1321
1322 # If it didn't work, it could be that there is a full legal character
1323 # followed by a partial or malformed one. Narrow the window and
1324 # try again.
1325 $limit--;
1326 }
1327
1328 # Failed to find a legal UTF-8 character.
1329 $utf8_len = 0;
1330 return;
1331 }
1332
1333
1334 sub decode_error {
1335 my $error = shift;
1336 my $no_rep = shift;
1337 my $str = defined $text ? substr($text, $at) : '';
1338 my $mess = '';
1339 my $type = 'U*';
1340
1341 for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
1342 my $chr_c = chr($c);
1343 $mess .= $chr_c eq '\\' ? '\\\\'
1344 : $chr_c =~ /[[:print:]]/ ? $chr_c
1345 : $chr_c eq '\a' ? '\a'
1346 : $chr_c eq '\t' ? '\t'
1347 : $chr_c eq '\n' ? '\n'
1348 : $chr_c eq '\r' ? '\r'
1349 : $chr_c eq '\f' ? '\f'
1350 : sprintf('\x{%x}', $c)
1351 ;
1352 if ( length $mess >= 20 ) {
1353 $mess .= '...';
1354 last;
1355 }
1356 }
1357
1358 unless ( length $mess ) {
1359 $mess = '(end of string)';
1360 }
1361
1362 Carp::croak (
1363 $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
1364 );
1365
1366 }
1367
1368
1369 sub _json_object_hook {
1370 my $o = $_[0];
1371 my @ks = keys %{$o};
1372
1373 if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
1374 my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
1375 if (@val == 0) {
1376 return $o;
1377 }
1378 elsif (@val == 1) {
1379 return $val[0];
1380 }
1381 else {
1382 Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar");
1383 }
1384 }
1385
1386 my @val = $cb_object->($o) if ($cb_object);
1387 if (@val == 0) {
1388 return $o;
1389 }
1390 elsif (@val == 1) {
1391 return $val[0];
1392 }
1393 else {
1394 Carp::croak("filter_json_object callbacks must not return more than one scalar");
1395 }
1396 }
1397
1398
1399 sub PP_decode_box {
1400 {
1401 text => $text,
1402 at => $at,
1403 ch => $ch,
1404 len => $len,
1405 depth => $depth,
1406 encoding => $encoding,
1407 is_valid_utf8 => $is_valid_utf8,
1408 };
1409 }
1410
1411} # PARSE
1412
1413
14141100nssub _decode_surrogates { # from perlunicode
1415 my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
1416 my $un = pack('U*', $uni);
1417 utf8::encode( $un );
1418 return $un;
1419}
1420
1421
1422sub _decode_unicode {
1423 my $un = pack('U', hex shift);
1424 utf8::encode( $un );
1425 return $un;
1426}
1427
1428sub incr_parse {
1429 local $Carp::CarpLevel = 1;
1430 ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
1431}
1432
1433
1434sub incr_skip {
1435 ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
1436}
1437
1438
1439sub incr_reset {
1440 ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
1441}
1442
1443sub incr_text : lvalue {
1444 $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
1445
1446 if ( $_[0]->{_incr_parser}->{incr_pos} ) {
1447 Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
1448 }
1449 $_[0]->{_incr_parser}->{incr_text};
1450}
1451
1452
1453###############################
1454# Utilities
1455#
1456
1457# shamelessly copied and modified from JSON::XS code.
1458
14591900ns$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
14601300ns$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1461
1462sub is_bool {
1463 if (blessed $_[0]) {
1464 return (
1465 $_[0]->isa("JSON::PP::Boolean")
1466 or $_[0]->isa("Types::Serialiser::BooleanBase")
1467 or $_[0]->isa("JSON::XS::Boolean")
1468 );
1469 }
1470 elsif (CORE_BOOL) {
1471163µs229µs
# spent 17µs (4+12) within JSON::PP::BEGIN@1471 which was called: # once (4µs+12µs) by JSON::BEGIN@1 at line 1471
BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
# spent 17µs making 1 call to JSON::PP::BEGIN@1471 # spent 12µs making 1 call to warnings::unimport
1472 return builtin::is_bool($_[0]);
1473 }
1474 return !!0;
1475}
1476
1477sub true { $JSON::PP::true }
1478sub false { $JSON::PP::false }
1479sub null { undef; }
1480
1481###############################
1482
1483package JSON::PP::IncrParser;
1484
1485223µs28µs
# spent 6µs (5+1) within JSON::PP::IncrParser::BEGIN@1485 which was called: # once (5µs+1µs) by JSON::BEGIN@1 at line 1485
use strict;
# spent 6µs making 1 call to JSON::PP::IncrParser::BEGIN@1485 # spent 1µs making 1 call to strict::import
1486
1487217µs272µs
# spent 38µs (4+34) within JSON::PP::IncrParser::BEGIN@1487 which was called: # once (4µs+34µs) by JSON::BEGIN@1 at line 1487
use constant INCR_M_WS => 0; # initial whitespace skipping
# spent 38µs making 1 call to JSON::PP::IncrParser::BEGIN@1487 # spent 34µs making 1 call to constant::import
1488213µs237µs
# spent 20µs (4+17) within JSON::PP::IncrParser::BEGIN@1488 which was called: # once (4µs+17µs) by JSON::BEGIN@1 at line 1488
use constant INCR_M_STR => 1; # inside string
# spent 20µs making 1 call to JSON::PP::IncrParser::BEGIN@1488 # spent 17µs making 1 call to constant::import
1489217µs231µs
# spent 17µs (3+14) within JSON::PP::IncrParser::BEGIN@1489 which was called: # once (3µs+14µs) by JSON::BEGIN@1 at line 1489
use constant INCR_M_BS => 2; # inside backslash
# spent 17µs making 1 call to JSON::PP::IncrParser::BEGIN@1489 # spent 14µs making 1 call to constant::import
1490212µs231µs
# spent 17µs (3+14) within JSON::PP::IncrParser::BEGIN@1490 which was called: # once (3µs+14µs) by JSON::BEGIN@1 at line 1490
use constant INCR_M_JSON => 3; # outside anything, count nesting
# spent 17µs making 1 call to JSON::PP::IncrParser::BEGIN@1490 # spent 14µs making 1 call to constant::import
1491215µs231µs
# spent 17µs (2+14) within JSON::PP::IncrParser::BEGIN@1491 which was called: # once (2µs+14µs) by JSON::BEGIN@1 at line 1491
use constant INCR_M_C0 => 4;
# spent 17µs making 1 call to JSON::PP::IncrParser::BEGIN@1491 # spent 14µs making 1 call to constant::import
1492212µs230µs
# spent 16µs (3+13) within JSON::PP::IncrParser::BEGIN@1492 which was called: # once (3µs+13µs) by JSON::BEGIN@1 at line 1492
use constant INCR_M_C1 => 5;
# spent 16µs making 1 call to JSON::PP::IncrParser::BEGIN@1492 # spent 13µs making 1 call to constant::import
1493216µs236µs
# spent 24µs (11+13) within JSON::PP::IncrParser::BEGIN@1493 which was called: # once (11µs+13µs) by JSON::BEGIN@1 at line 1493
use constant INCR_M_TFN => 6;
# spent 24µs making 1 call to JSON::PP::IncrParser::BEGIN@1493 # spent 13µs making 1 call to constant::import
14942156µs230µs
# spent 16µs (3+13) within JSON::PP::IncrParser::BEGIN@1494 which was called: # once (3µs+13µs) by JSON::BEGIN@1 at line 1494
use constant INCR_M_NUM => 7;
# spent 16µs making 1 call to JSON::PP::IncrParser::BEGIN@1494 # spent 13µs making 1 call to constant::import
1495
14961200nsour $VERSION = '1.01';
1497
1498sub new {
1499 my ( $class ) = @_;
1500
1501 bless {
1502 incr_nest => 0,
1503 incr_text => undef,
1504 incr_pos => 0,
1505 incr_mode => 0,
1506 }, $class;
1507}
1508
1509
1510sub incr_parse {
1511 my ( $self, $coder, $text ) = @_;
1512
1513 $self->{incr_text} = '' unless ( defined $self->{incr_text} );
1514
1515 if ( defined $text ) {
1516 $self->{incr_text} .= $text;
1517 }
1518
1519 if ( defined wantarray ) {
1520 my $max_size = $coder->get_max_size;
1521 my $p = $self->{incr_pos};
1522 my @ret;
1523 {
1524 do {
1525 unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
1526 $self->_incr_parse( $coder );
1527
1528 if ( $max_size and $self->{incr_pos} > $max_size ) {
1529 Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size");
1530 }
1531 unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
1532 # as an optimisation, do not accumulate white space in the incr buffer
1533 if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) {
1534 $self->{incr_pos} = 0;
1535 $self->{incr_text} = '';
1536 }
1537 last;
1538 }
1539 }
1540
1541 unless ( $coder->get_utf8 ) {
1542 utf8::decode( $self->{incr_text} );
1543 }
1544
1545 my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
1546 push @ret, $obj;
15472547µs28µs
# spent 7µs (6+1) within JSON::PP::IncrParser::BEGIN@1547 which was called: # once (6µs+1µs) by JSON::BEGIN@1 at line 1547
use bytes;
# spent 7µs making 1 call to JSON::PP::IncrParser::BEGIN@1547 # spent 1µs making 1 call to bytes::import
1548 $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 );
1549 $self->{incr_pos} = 0;
1550 $self->{incr_nest} = 0;
1551 $self->{incr_mode} = 0;
1552 last unless wantarray;
1553 } while ( wantarray );
1554 }
1555
1556 if ( wantarray ) {
1557 return @ret;
1558 }
1559 else { # in scalar context
1560 return defined $ret[0] ? $ret[0] : undef;
1561 }
1562 }
1563}
1564
1565
1566sub _incr_parse {
1567 my ($self, $coder) = @_;
1568 my $text = $self->{incr_text};
1569 my $len = length $text;
1570 my $p = $self->{incr_pos};
1571
1572INCR_PARSE:
1573 while ( $len > $p ) {
1574 my $s = substr( $text, $p, 1 );
1575 last INCR_PARSE unless defined $s;
1576 my $mode = $self->{incr_mode};
1577
1578 if ( $mode == INCR_M_WS ) {
1579 while ( $len > $p ) {
1580 $s = substr( $text, $p, 1 );
1581 last INCR_PARSE unless defined $s;
1582 if ( ord($s) > ord " " ) {
1583 if ( $s eq '#' ) {
1584 $self->{incr_mode} = INCR_M_C0;
1585 redo INCR_PARSE;
1586 } else {
1587 $self->{incr_mode} = INCR_M_JSON;
1588 redo INCR_PARSE;
1589 }
1590 }
1591 $p++;
1592 }
1593 } elsif ( $mode == INCR_M_BS ) {
1594 $p++;
1595 $self->{incr_mode} = INCR_M_STR;
1596 redo INCR_PARSE;
1597 } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) {
1598 while ( $len > $p ) {
1599 $s = substr( $text, $p, 1 );
1600 last INCR_PARSE unless defined $s;
1601 if ( $s eq "\n" ) {
1602 $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;
1603 last;
1604 }
1605 $p++;
1606 }
1607 next;
1608 } elsif ( $mode == INCR_M_TFN ) {
1609 last INCR_PARSE if $p >= $len && $self->{incr_nest};
1610 while ( $len > $p ) {
1611 $s = substr( $text, $p++, 1 );
1612 next if defined $s and $s =~ /[rueals]/;
1613 last;
1614 }
1615 $p--;
1616 $self->{incr_mode} = INCR_M_JSON;
1617
1618 last INCR_PARSE unless $self->{incr_nest};
1619 redo INCR_PARSE;
1620 } elsif ( $mode == INCR_M_NUM ) {
1621 last INCR_PARSE if $p >= $len && $self->{incr_nest};
1622 while ( $len > $p ) {
1623 $s = substr( $text, $p++, 1 );
1624 next if defined $s and $s =~ /[0-9eE.+\-]/;
1625 last;
1626 }
1627 $p--;
1628 $self->{incr_mode} = INCR_M_JSON;
1629
1630 last INCR_PARSE unless $self->{incr_nest};
1631 redo INCR_PARSE;
1632 } elsif ( $mode == INCR_M_STR ) {
1633 while ( $len > $p ) {
1634 $s = substr( $text, $p, 1 );
1635 last INCR_PARSE unless defined $s;
1636 if ( $s eq '"' ) {
1637 $p++;
1638 $self->{incr_mode} = INCR_M_JSON;
1639
1640 last INCR_PARSE unless $self->{incr_nest};
1641 redo INCR_PARSE;
1642 }
1643 elsif ( $s eq '\\' ) {
1644 $p++;
1645 if ( !defined substr($text, $p, 1) ) {
1646 $self->{incr_mode} = INCR_M_BS;
1647 last INCR_PARSE;
1648 }
1649 }
1650 $p++;
1651 }
1652 } elsif ( $mode == INCR_M_JSON ) {
1653 while ( $len > $p ) {
1654 $s = substr( $text, $p++, 1 );
1655 if ( $s eq "\x00" ) {
1656 $p--;
1657 last INCR_PARSE;
1658 } elsif ( $s =~ /^[\t\n\r ]$/) {
1659 if ( !$self->{incr_nest} ) {
1660 $p--; # do not eat the whitespace, let the next round do it
1661 last INCR_PARSE;
1662 }
1663 next;
1664 } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) {
1665 $self->{incr_mode} = INCR_M_TFN;
1666 redo INCR_PARSE;
1667 } elsif ( $s =~ /^[0-9\-]$/ ) {
1668 $self->{incr_mode} = INCR_M_NUM;
1669 redo INCR_PARSE;
1670 } elsif ( $s eq '"' ) {
1671 $self->{incr_mode} = INCR_M_STR;
1672 redo INCR_PARSE;
1673 } elsif ( $s eq '[' or $s eq '{' ) {
1674 if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
1675 Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
1676 }
1677 next;
1678 } elsif ( $s eq ']' or $s eq '}' ) {
1679 if ( --$self->{incr_nest} <= 0 ) {
1680 last INCR_PARSE;
1681 }
1682 } elsif ( $s eq '#' ) {
1683 $self->{incr_mode} = INCR_M_C1;
1684 redo INCR_PARSE;
1685 }
1686 }
1687 }
1688 }
1689
1690 $self->{incr_pos} = $p;
1691 $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility
1692}
1693
1694
1695sub incr_text {
1696 if ( $_[0]->{incr_pos} ) {
1697 Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
1698 }
1699 $_[0]->{incr_text};
1700}
1701
1702
1703sub incr_skip {
1704 my $self = shift;
1705 $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} );
1706 $self->{incr_pos} = 0;
1707 $self->{incr_mode} = 0;
1708 $self->{incr_nest} = 0;
1709}
1710
1711
1712sub incr_reset {
1713 my $self = shift;
1714 $self->{incr_text} = undef;
1715 $self->{incr_pos} = 0;
1716 $self->{incr_mode} = 0;
1717 $self->{incr_nest} = 0;
1718}
1719
1720###############################
1721
1722
172318µs1;
1724__END__