Profile of JSON/PP.pm

← 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
Statements | Executed 242 statements in 6.47ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 981µs | 981µs | JSON::PP::::BEGIN@68 JSON::PP::BEGIN@68
1 | 1 | 1 | 158µs | 220µs | JSON::PP::::BEGIN@12 JSON::PP::BEGIN@12
1 | 1 | 1 | 100µs | 109µs | JSON::PP::::BEGIN@688 JSON::PP::BEGIN@688
1 | 1 | 1 | 26µs | 40µs | JSON::PP::::BEGIN@53 JSON::PP::BEGIN@53
1 | 1 | 1 | 15µs | 30µs | JSON::PP::::BEGIN@26 JSON::PP::BEGIN@26
1 | 1 | 1 | 11µs | 24µs | JSON::PP::IncrParser::::BEGIN@1493JSON::PP::IncrParser::BEGIN@1493
1 | 1 | 1 | 11µs | 11µs | JSON::PP::::BEGIN@5 JSON::PP::BEGIN@5
1 | 1 | 1 | 10µs | 12µs | JSON::PP::::BEGIN@790 JSON::PP::BEGIN@790
1 | 1 | 1 | 9µs | 9µs | JSON::PP::::BEGIN@9 JSON::PP::BEGIN@9
1 | 1 | 1 | 6µs | 7µs | JSON::PP::IncrParser::::BEGIN@1547JSON::PP::IncrParser::BEGIN@1547
1 | 1 | 1 | 6µs | 18µs | JSON::PP::::BEGIN@46 JSON::PP::BEGIN@46
1 | 1 | 1 | 5µs | 19µs | JSON::PP::::BEGIN@1285 JSON::PP::BEGIN@1285
1 | 1 | 1 | 5µs | 19µs | JSON::PP::::BEGIN@493 JSON::PP::BEGIN@493
1 | 1 | 1 | 5µs | 19µs | JSON::PP::::BEGIN@209 JSON::PP::BEGIN@209
1 | 1 | 1 | 5µs | 6µs | JSON::PP::IncrParser::::BEGIN@1485JSON::PP::IncrParser::BEGIN@1485
1 | 1 | 1 | 4µs | 17µs | JSON::PP::::BEGIN@1471 JSON::PP::BEGIN@1471
1 | 1 | 1 | 4µs | 23µs | JSON::PP::::BEGIN@15 JSON::PP::BEGIN@15
1 | 1 | 1 | 4µs | 35µs | JSON::PP::::BEGIN@25 JSON::PP::BEGIN@25
1 | 1 | 1 | 4µs | 6µs | JSON::PP::::BEGIN@6 JSON::PP::BEGIN@6
1 | 1 | 1 | 4µs | 15µs | JSON::PP::::BEGIN@515 JSON::PP::BEGIN@515
1 | 1 | 1 | 4µs | 38µs | JSON::PP::IncrParser::::BEGIN@1487JSON::PP::IncrParser::BEGIN@1487
1 | 1 | 1 | 4µs | 20µs | JSON::PP::IncrParser::::BEGIN@1488JSON::PP::IncrParser::BEGIN@1488
1 | 1 | 1 | 3µs | 17µs | JSON::PP::IncrParser::::BEGIN@1490JSON::PP::IncrParser::BEGIN@1490
1 | 1 | 1 | 3µs | 19µs | JSON::PP::::BEGIN@39 JSON::PP::BEGIN@39
1 | 1 | 1 | 3µs | 18µs | JSON::PP::::BEGIN@48 JSON::PP::BEGIN@48
1 | 1 | 1 | 3µs | 16µs | JSON::PP::IncrParser::::BEGIN@1492JSON::PP::IncrParser::BEGIN@1492
1 | 1 | 1 | 3µs | 16µs | JSON::PP::IncrParser::::BEGIN@1494JSON::PP::IncrParser::BEGIN@1494
1 | 1 | 1 | 3µs | 18µs | JSON::PP::::BEGIN@27 JSON::PP::BEGIN@27
1 | 1 | 1 | 3µs | 32µs | JSON::PP::::BEGIN@29 JSON::PP::BEGIN@29
1 | 1 | 1 | 3µs | 15µs | JSON::PP::::BEGIN@49 JSON::PP::BEGIN@49
1 | 1 | 1 | 3µs | 15µs | JSON::PP::::BEGIN@35 JSON::PP::BEGIN@35
1 | 1 | 1 | 3µs | 17µs | JSON::PP::IncrParser::::BEGIN@1489JSON::PP::IncrParser::BEGIN@1489
1 | 1 | 1 | 3µs | 17µs | JSON::PP::::BEGIN@38 JSON::PP::BEGIN@38
1 | 1 | 1 | 3µs | 16µs | JSON::PP::::BEGIN@31 JSON::PP::BEGIN@31
1 | 1 | 1 | 3µs | 15µs | JSON::PP::::BEGIN@33 JSON::PP::BEGIN@33
1 | 1 | 1 | 3µs | 16µs | JSON::PP::::BEGIN@45 JSON::PP::BEGIN@45
1 | 1 | 1 | 2µs | 17µs | JSON::PP::::BEGIN@28 JSON::PP::BEGIN@28
1 | 1 | 1 | 2µs | 15µs | JSON::PP::::BEGIN@32 JSON::PP::BEGIN@32
1 | 1 | 1 | 2µs | 15µs | JSON::PP::::BEGIN@36 JSON::PP::BEGIN@36
1 | 1 | 1 | 2µs | 18µs | JSON::PP::::BEGIN@43 JSON::PP::BEGIN@43
1 | 1 | 1 | 2µs | 17µs | JSON::PP::IncrParser::::BEGIN@1491JSON::PP::IncrParser::BEGIN@1491
1 | 1 | 1 | 2µs | 16µs | JSON::PP::::BEGIN@30 JSON::PP::BEGIN@30
1 | 1 | 1 | 2µs | 15µs | JSON::PP::::BEGIN@41 JSON::PP::BEGIN@41
1 | 1 | 1 | 2µs | 15µs | JSON::PP::::BEGIN@42 JSON::PP::BEGIN@42
1 | 1 | 1 | 2µs | 15µs | JSON::PP::::BEGIN@34 JSON::PP::BEGIN@34
1 | 1 | 1 | 2µs | 16µs | JSON::PP::::BEGIN@40 JSON::PP::BEGIN@40
1 | 1 | 1 | 2µs | 2µs | JSON::PP::::BEGIN@14 JSON::PP::BEGIN@14
1 | 1 | 1 | 2µs | 2µs | JSON::PP::::BEGIN@11 JSON::PP::BEGIN@11
1 | 1 | 1 | 2µs | 2µs | JSON::PP::::BEGIN@62 JSON::PP::BEGIN@62
1 | 1 | 1 | 1µs | 1µs | JSON::PP::::BEGIN@8 JSON::PP::BEGIN@8
0 | 0 | 0 | 0s | 0s | JSON::PP::IncrParser::::_incr_parseJSON::PP::IncrParser::_incr_parse
0 | 0 | 0 | 0s | 0s | JSON::PP::IncrParser::::incr_parseJSON::PP::IncrParser::incr_parse
0 | 0 | 0 | 0s | 0s | JSON::PP::IncrParser::::incr_resetJSON::PP::IncrParser::incr_reset
0 | 0 | 0 | 0s | 0s | JSON::PP::IncrParser::::incr_skipJSON::PP::IncrParser::incr_skip
0 | 0 | 0 | 0s | 0s | JSON::PP::IncrParser::::incr_textJSON::PP::IncrParser::incr_text
0 | 0 | 0 | 0s | 0s | JSON::PP::IncrParser::::newJSON::PP::IncrParser::new
0 | 0 | 0 | 0s | 0s | JSON::PP::::PP_decode_box JSON::PP::PP_decode_box
0 | 0 | 0 | 0s | 0s | JSON::PP::::PP_decode_json JSON::PP::PP_decode_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::PP_encode_box JSON::PP::PP_encode_box
0 | 0 | 0 | 0s | 0s | JSON::PP::::PP_encode_json JSON::PP::PP_encode_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::__ANON__[:359] JSON::PP::__ANON__[:359]
0 | 0 | 0 | 0s | 0s | JSON::PP::::__ANON__[:364] JSON::PP::__ANON__[:364]
0 | 0 | 0 | 0s | 0s | JSON::PP::::_decode_surrogates JSON::PP::_decode_surrogates
0 | 0 | 0 | 0s | 0s | JSON::PP::::_decode_unicode JSON::PP::_decode_unicode
0 | 0 | 0 | 0s | 0s | JSON::PP::::_detect_utf_encoding JSON::PP::_detect_utf_encoding
0 | 0 | 0 | 0s | 0s | JSON::PP::::_down_indent JSON::PP::_down_indent
0 | 0 | 0 | 0s | 0s | JSON::PP::::_encode_ascii JSON::PP::_encode_ascii
0 | 0 | 0 | 0s | 0s | JSON::PP::::_encode_latin1 JSON::PP::_encode_latin1
0 | 0 | 0 | 0s | 0s | JSON::PP::::_encode_surrogates JSON::PP::_encode_surrogates
0 | 0 | 0 | 0s | 0s | JSON::PP::::_is_bignum JSON::PP::_is_bignum
0 | 0 | 0 | 0s | 0s | JSON::PP::::_json_object_hook JSON::PP::_json_object_hook
0 | 0 | 0 | 0s | 0s | JSON::PP::::_looks_like_number JSON::PP::_looks_like_number
0 | 0 | 0 | 0s | 0s | JSON::PP::::_sort JSON::PP::_sort
0 | 0 | 0 | 0s | 0s | JSON::PP::::_up_indent JSON::PP::_up_indent
0 | 0 | 0 | 0s | 0s | JSON::PP::::allow_bigint JSON::PP::allow_bigint
0 | 0 | 0 | 0s | 0s | JSON::PP::::array JSON::PP::array
0 | 0 | 0 | 0s | 0s | JSON::PP::::array_to_json JSON::PP::array_to_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::bareKey JSON::PP::bareKey
0 | 0 | 0 | 0s | 0s | JSON::PP::::blessed_to_json JSON::PP::blessed_to_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::boolean_values JSON::PP::boolean_values
0 | 0 | 0 | 0s | 0s | JSON::PP::::core_bools JSON::PP::core_bools
0 | 0 | 0 | 0s | 0s | JSON::PP::::decode JSON::PP::decode
0 | 0 | 0 | 0s | 0s | JSON::PP::::decode_error JSON::PP::decode_error
0 | 0 | 0 | 0s | 0s | JSON::PP::::decode_json JSON::PP::decode_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::decode_prefix JSON::PP::decode_prefix
0 | 0 | 0 | 0s | 0s | JSON::PP::::encode JSON::PP::encode
0 | 0 | 0 | 0s | 0s | JSON::PP::::encode_error JSON::PP::encode_error
0 | 0 | 0 | 0s | 0s | JSON::PP::::encode_json JSON::PP::encode_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::false JSON::PP::false
0 | 0 | 0 | 0s | 0s | JSON::PP::::filter_json_object JSON::PP::filter_json_object
0 | 0 | 0 | 0s | 0s | JSON::PP::::filter_json_single_key_object JSON::PP::filter_json_single_key_object
0 | 0 | 0 | 0s | 0s | JSON::PP::::from_json JSON::PP::from_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::get_boolean_values JSON::PP::get_boolean_values
0 | 0 | 0 | 0s | 0s | JSON::PP::::get_core_bools JSON::PP::get_core_bools
0 | 0 | 0 | 0s | 0s | JSON::PP::::get_indent_length JSON::PP::get_indent_length
0 | 0 | 0 | 0s | 0s | JSON::PP::::get_max_depth JSON::PP::get_max_depth
0 | 0 | 0 | 0s | 0s | JSON::PP::::get_max_size JSON::PP::get_max_size
0 | 0 | 0 | 0s | 0s | JSON::PP::::get_unblessed_bool JSON::PP::get_unblessed_bool
0 | 0 | 0 | 0s | 0s | JSON::PP::::hash_to_json JSON::PP::hash_to_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::incr_parse JSON::PP::incr_parse
0 | 0 | 0 | 0s | 0s | JSON::PP::::incr_reset JSON::PP::incr_reset
0 | 0 | 0 | 0s | 0s | JSON::PP::::incr_skip JSON::PP::incr_skip
0 | 0 | 0 | 0s | 0s | JSON::PP::::incr_text JSON::PP::incr_text
0 | 0 | 0 | 0s | 0s | JSON::PP::::indent_length JSON::PP::indent_length
0 | 0 | 0 | 0s | 0s | JSON::PP::::is_bool JSON::PP::is_bool
0 | 0 | 0 | 0s | 0s | JSON::PP::::is_valid_utf8 JSON::PP::is_valid_utf8
0 | 0 | 0 | 0s | 0s | JSON::PP::::max_depth JSON::PP::max_depth
0 | 0 | 0 | 0s | 0s | JSON::PP::::max_size JSON::PP::max_size
0 | 0 | 0 | 0s | 0s | JSON::PP::::new JSON::PP::new
0 | 0 | 0 | 0s | 0s | JSON::PP::::next_chr JSON::PP::next_chr
0 | 0 | 0 | 0s | 0s | JSON::PP::::null JSON::PP::null
0 | 0 | 0 | 0s | 0s | JSON::PP::::number JSON::PP::number
0 | 0 | 0 | 0s | 0s | JSON::PP::::object JSON::PP::object
0 | 0 | 0 | 0s | 0s | JSON::PP::::object_to_json JSON::PP::object_to_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::pretty JSON::PP::pretty
0 | 0 | 0 | 0s | 0s | JSON::PP::::sort_by JSON::PP::sort_by
0 | 0 | 0 | 0s | 0s | JSON::PP::::string JSON::PP::string
0 | 0 | 0 | 0s | 0s | JSON::PP::::string_to_json JSON::PP::string_to_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::tag JSON::PP::tag
0 | 0 | 0 | 0s | 0s | JSON::PP::::to_json JSON::PP::to_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::true JSON::PP::true
0 | 0 | 0 | 0s | 0s | JSON::PP::::unblessed_bool JSON::PP::unblessed_bool
0 | 0 | 0 | 0s | 0s | JSON::PP::::value JSON::PP::value
0 | 0 | 0 | 0s | 0s | JSON::PP::::value_to_json JSON::PP::value_to_json
0 | 0 | 0 | 0s | 0s | JSON::PP::::white JSON::PP::white
0 | 0 | 0 | 0s | 0s | JSON::PP::::word JSON::PP::word

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package JSON::PP;
2 |  |  |  |  |
3 |  |  |  |  | # JSON-2.0
4 |  |  |  |  |
5 | 2 | 28µs | 1 | 11µ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
6 | 2 | 14µs | 2 | 7µ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 |  |  |  |  |
8 | 2 | 18µs | 1 | 1µ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
9 | 1 | 24µs | 1 | 9µ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 |  |  |  |  |
11 | 2 | 11µs | 1 | 2µ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
12 | 2 | 72µs | 2 | 220µ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 |  |  |  |  |
14 | 2 | 13µs | 1 | 2µ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
15 | 2 | 29µs | 2 | 42µ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 |  |  |  |  |
18 | 1 | 400ns |  |  | our $VERSION = '4.16';
19 |  |  |  |  |
20 | 1 | 1µs |  |  | our @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 |  |  |  |  |
25 | 2 | 16µs | 2 | 65µ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
26 | 2 | 14µs | 2 | 45µ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
27 | 2 | 12µs | 2 | 34µ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
28 | 2 | 12µs | 2 | 32µ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
29 | 2 | 12µs | 2 | 62µ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
30 | 2 | 11µs | 2 | 29µ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
31 | 2 | 12µs | 2 | 28µ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
32 | 2 | 12µs | 2 | 28µ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
33 | 2 | 11µs | 2 | 27µ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
34 | 2 | 11µs | 2 | 28µ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
35 | 2 | 11µs | 2 | 28µ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
36 | 2 | 20µs | 2 | 28µ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 |  |  |  |  |
38 | 2 | 27µs | 2 | 32µ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
39 | 2 | 13µs | 2 | 34µ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
40 | 2 | 11µs | 2 | 30µ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
41 | 2 | 11µs | 2 | 28µ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
42 | 2 | 11µs | 2 | 27µ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
43 | 2 | 16µs | 2 | 34µ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 |  |  |  |  |
45 | 2 | 11µs | 2 | 29µ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
46 | 2 | 19µs | 2 | 31µ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 |  |  |  |  |
48 | 2 | 17µs | 2 | 33µ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
49 | 2 | 64µs | 2 | 28µ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 |  |  |  |  |
51 | 1 | 100ns |  |  | my $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 {
54 | 1 | 400ns |  |  | $invalid_char_re = "[";
55 | 1 | 700ns |  |  | for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok
56 | 34 | 13µs |  |  | $invalid_char_re .= quotemeta chr utf8::unicode_to_native($i);
57 |  |  |  |  | }
58 |  |  |  |  |
59 | 1 | 26µs | 2 | 15µ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
60 | 1 | 25µs | 1 | 40µ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 {
63 | 1 | 2µs |  |  | if (USE_B) {
64 |  |  |  |  | require B;
65 |  |  |  |  | }
66 | 1 | 64µs | 1 | 2µ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 {
69 | 1 | 1µ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 |  |  |  |  | );
74 | 1 | 500ns |  |  | my @pp_bit_properties = qw(
75 |  |  |  |  | allow_singlequote allow_bignum loose
76 |  |  |  |  | allow_barekey escape_slash as_nonblessed
77 |  |  |  |  | );
78 |  |  |  |  |
79 | 1 | 5µs |  |  | for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
80 | 20 | 7µs |  |  | my $property_id = 'P_' . uc($name);
81 |  |  |  |  |
82 | 20 | 969µ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 |  |  |  |  |
102 | 1 | 245µs | 1 | 981µs | } # spent 981µs making 1 call to JSON::PP::BEGIN@68
103 |  |  |  |  |
- - |  |  |  |  |
106 |  |  |  |  | # Functions
107 |  |  |  |  |
108 |  |  |  |  | my $JSON; # cache
109 |  |  |  |  |
110 |  |  |  |  | sub encode_json ($) { # encode
111 |  |  |  |  | ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
112 |  |  |  |  | }
113 |  |  |  |  |
114 |  |  |  |  |
115 |  |  |  |  | sub decode_json { # decode
116 |  |  |  |  | ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
117 |  |  |  |  | }
118 |  |  |  |  |
119 |  |  |  |  | # Obsoleted
120 |  |  |  |  |
121 |  |  |  |  | sub to_json($) {
122 |  |  |  |  | Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
123 |  |  |  |  | }
124 |  |  |  |  |
125 |  |  |  |  |
126 |  |  |  |  | sub from_json($) {
127 |  |  |  |  | Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
128 |  |  |  |  | }
129 |  |  |  |  |
130 |  |  |  |  |
131 |  |  |  |  | # Methods
132 |  |  |  |  |
133 |  |  |  |  | sub 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 |  |  |  |  |
147 |  |  |  |  | sub encode {
148 |  |  |  |  | return $_[0]->PP_encode_json($_[1]);
149 |  |  |  |  | }
150 |  |  |  |  |
151 |  |  |  |  |
152 |  |  |  |  | sub decode {
153 |  |  |  |  | return $_[0]->PP_decode_json($_[1], 0x00000000);
154 |  |  |  |  | }
155 |  |  |  |  |
156 |  |  |  |  |
157 |  |  |  |  | sub decode_prefix {
158 |  |  |  |  | return $_[0]->PP_decode_json($_[1], 0x00000001);
159 |  |  |  |  | }
160 |  |  |  |  |
161 |  |  |  |  |
162 |  |  |  |  | # accessor
163 |  |  |  |  |
164 |  |  |  |  |
165 |  |  |  |  | # pretty printing
166 |  |  |  |  |
167 |  |  |  |  | sub 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 |  |  |  |  |
183 |  |  |  |  | sub max_depth {
184 |  |  |  |  | my $max = defined $_[1] ? $_[1] : 0x80000000;
185 |  |  |  |  | $_[0]->{max_depth} = $max;
186 |  |  |  |  | $_[0];
187 |  |  |  |  | }
188 |  |  |  |  |
189 |  |  |  |  |
190 |  |  |  |  | sub get_max_depth { $_[0]->{max_depth}; }
191 |  |  |  |  |
192 |  |  |  |  |
193 |  |  |  |  | sub max_size {
194 |  |  |  |  | my $max = defined $_[1] ? $_[1] : 0;
195 |  |  |  |  | $_[0]->{max_size} = $max;
196 |  |  |  |  | $_[0];
197 |  |  |  |  | }
198 |  |  |  |  |
199 |  |  |  |  |
200 |  |  |  |  | sub get_max_size { $_[0]->{max_size}; }
201 |  |  |  |  |
202 |  |  |  |  | sub boolean_values {
203 |  |  |  |  | my $self = shift;
204 |  |  |  |  | if (@_) {
205 |  |  |  |  | my ($false, $true) = @_;
206 |  |  |  |  | $self->{false} = $false;
207 |  |  |  |  | $self->{true} = $true;
208 |  |  |  |  | if (CORE_BOOL) {
209 | 1 | 866µs | 2 | 33µ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 |  |  |  |  |
225 |  |  |  |  | sub 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 |  |  |  |  |
241 |  |  |  |  | sub get_core_bools {
242 |  |  |  |  | my $self = shift;
243 |  |  |  |  | return !!$self->{core_bools};
244 |  |  |  |  | }
245 |  |  |  |  |
246 |  |  |  |  | sub unblessed_bool {
247 |  |  |  |  | my $self = shift;
248 |  |  |  |  | return $self->core_bools(@_);
249 |  |  |  |  | }
250 |  |  |  |  |
251 |  |  |  |  | sub get_unblessed_bool {
252 |  |  |  |  | my $self = shift;
253 |  |  |  |  | return $self->get_core_bools(@_);
254 |  |  |  |  | }
255 |  |  |  |  |
256 |  |  |  |  | sub 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 |  |  |  |  |
264 |  |  |  |  | sub 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 |  |  |  |  |
274 |  |  |  |  | sub 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 |  |  |  |  |
288 |  |  |  |  | sub 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 |  |  |  |  |
298 |  |  |  |  | sub get_indent_length {
299 |  |  |  |  | $_[0]->{indent_length};
300 |  |  |  |  | }
301 |  |  |  |  |
302 |  |  |  |  | sub sort_by {
303 |  |  |  |  | $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
304 |  |  |  |  | $_[0];
305 |  |  |  |  | }
306 |  |  |  |  |
307 |  |  |  |  | sub 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 |  |  |  |  |
321 | 1 | 100ns |  |  | 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 {
493 | 2 | 78µs | 2 | 33µ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) {
515 | 1 | 539µs | 2 | 26µ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 |  |  |  |  |
555 | 1 | 3µ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 |  |  |  |  |
646 | 1 | 200ns |  |  | sub _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 |  |  |  |  |
658 |  |  |  |  | sub _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 |  |  |  |  |
670 |  |  |  |  | sub _encode_surrogates { # from perlunicode
671 |  |  |  |  | my $uni = $_[0] - 0x10000;
672 |  |  |  |  | return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
673 |  |  |  |  | }
674 |  |  |  |  |
675 |  |  |  |  |
676 |  |  |  |  | sub _is_bignum {
677 |  |  |  |  | $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
678 |  |  |  |  | }
679 |  |  |  |  |
- - |  |  |  |  |
682 |  |  |  |  | #
683 |  |  |  |  | # JSON => Perl
684 |  |  |  |  | #
685 |  |  |  |  |
686 | 1 | 200ns |  |  | my $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 {
689 | 1 | 200ns |  |  | my $checkint = 1111;
690 | 1 | 800ns |  |  | for my $d (5..64) {
691 | 17 | 1µs |  |  | $checkint .= 1;
692 | 17 | 67µ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
693 | 17 | 26µs | 17 | 9µs | if ($int =~ /[eE]/) { # spent 9µs making 17 calls to CORE::match, avg 524ns/call
694 | 1 | 200ns |  |  | $max_intsize = $d - 1;
695 | 1 | 3µs |  |  | last;
696 |  |  |  |  | }
697 |  |  |  |  | }
698 | 1 | 222µs | 1 | 109µs | } # spent 109µs making 1 call to JSON::PP::BEGIN@688
699 |  |  |  |  |
700 |  |  |  |  | { # PARSE
701 |  |  |  |  |
702 | 1 | 2µ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 |  |  |  |  |
713 | 1 | 100ns |  |  | 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) {
790 | 2 | 1.35ms | 2 | 15µ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
1284 | 1 | 400ns |  |  | my $max_unicode_length = do {
1285 | 2 | 482µs | 2 | 32µ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
1286 | 1 | 200ns |  |  | chr 0x10FFFF;
1287 |  |  |  |  | };
1288 | 1 | 5µs | 1 | 800ns | utf8::encode($max_unicode_length); # spent 800ns making 1 call to utf8::encode
1289 | 1 | 800ns |  |  | $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 |  |  |  |  |
1414 | 1 | 100ns |  |  | sub _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 |  |  |  |  |
1422 |  |  |  |  | sub _decode_unicode {
1423 |  |  |  |  | my $un = pack('U', hex shift);
1424 |  |  |  |  | utf8::encode( $un );
1425 |  |  |  |  | return $un;
1426 |  |  |  |  | }
1427 |  |  |  |  |
1428 |  |  |  |  | sub incr_parse {
1429 |  |  |  |  | local $Carp::CarpLevel = 1;
1430 |  |  |  |  | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
1431 |  |  |  |  | }
1432 |  |  |  |  |
1433 |  |  |  |  |
1434 |  |  |  |  | sub incr_skip {
1435 |  |  |  |  | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
1436 |  |  |  |  | }
1437 |  |  |  |  |
1438 |  |  |  |  |
1439 |  |  |  |  | sub incr_reset {
1440 |  |  |  |  | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
1441 |  |  |  |  | }
1442 |  |  |  |  |
1443 |  |  |  |  | sub 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 |  |  |  |  |
1459 | 1 | 900ns |  |  | $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
1460 | 1 | 300ns |  |  | $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1461 |  |  |  |  |
1462 |  |  |  |  | sub 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) {
1471 | 1 | 63µs | 2 | 29µ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 |  |  |  |  |
1477 |  |  |  |  | sub true { $JSON::PP::true }
1478 |  |  |  |  | sub false { $JSON::PP::false }
1479 |  |  |  |  | sub null { undef; }
1480 |  |  |  |  |
1481 |  |  |  |  | ###############################
1482 |  |  |  |  |
1483 |  |  |  |  | package JSON::PP::IncrParser;
1484 |  |  |  |  |
1485 | 2 | 23µs | 2 | 8µ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 |  |  |  |  |
1487 | 2 | 17µs | 2 | 72µ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
1488 | 2 | 13µs | 2 | 37µ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
1489 | 2 | 17µs | 2 | 31µ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
1490 | 2 | 12µs | 2 | 31µ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
1491 | 2 | 15µs | 2 | 31µ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
1492 | 2 | 12µs | 2 | 30µ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
1493 | 2 | 16µs | 2 | 36µ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
1494 | 2 | 156µs | 2 | 30µ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 |  |  |  |  |
1496 | 1 | 200ns |  |  | our $VERSION = '1.01';
1497 |  |  |  |  |
1498 |  |  |  |  | sub 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 |  |  |  |  |
1510 |  |  |  |  | sub 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;
1547 | 2 | 547µs | 2 | 8µ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 |  |  |  |  |
1566 |  |  |  |  | sub _incr_parse {
1567 |  |  |  |  | my ($self, $coder) = @_;
1568 |  |  |  |  | my $text = $self->{incr_text};
1569 |  |  |  |  | my $len = length $text;
1570 |  |  |  |  | my $p = $self->{incr_pos};
1571 |  |  |  |  |
1572 |  |  |  |  | INCR_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 |  |  |  |  |
1695 |  |  |  |  | sub 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 |  |  |  |  |
1703 |  |  |  |  | sub 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 |  |  |  |  |
1712 |  |  |  |  | sub 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 |  |  |  |  |
1723 | 1 | 8µs |  |  | 1;
1724 |  |  |  |  | __END__