← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:14 2021

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