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