File Coverage

blib/lib/JSON/Tiny.pm
Criterion Covered Total %
statement 120 121 99.1
branch 74 76 97.3
condition 13 17 76.4
subroutine 26 26 100.0
pod 7 7 100.0
total 240 247 97.1


line stmt bran cond sub pod time code
1             package JSON::Tiny;
2              
3             # Minimalistic JSON. Adapted from Mojo::JSON. (c)2012-2015 David Oswald
4             # License: Artistic 2.0 license.
5             # http://www.perlfoundation.org/artistic_license_2_0
6              
7 4     4   198941 use strict;
  4         39  
  4         101  
8 4     4   20 use warnings;
  4         7  
  4         105  
9 4     4   19 use Carp 'croak';
  4         7  
  4         173  
10 4     4   19 use Exporter 'import';
  4         5  
  4         97  
11 4     4   18 use Scalar::Util 'blessed';
  4         4  
  4         131  
12 4     4   989 use Encode ();
  4         24011  
  4         89  
13 4     4   25 use B;
  4         8  
  4         6997  
14              
15             our $VERSION = '0.58';
16             our @EXPORT_OK = qw(decode_json encode_json false from_json j to_json true);
17              
18             # Literal names
19             # Users may override Booleans with literal 0 or 1 if desired.
20             our($FALSE, $TRUE) = map { bless \(my $dummy = $_), 'JSON::Tiny::_Bool' } 0, 1;
21              
22             # Escaped special character map with u2028 and u2029
23             my %ESCAPE = (
24             '"' => '"',
25             '\\' => '\\',
26             '/' => '/',
27             'b' => "\x08",
28             'f' => "\x0c",
29             'n' => "\x0a",
30             'r' => "\x0d",
31             't' => "\x09",
32             'u2028' => "\x{2028}",
33             'u2029' => "\x{2029}"
34             );
35             my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
36              
37             for(0x00 .. 0x1f) {
38             my $packed = pack 'C', $_;
39             $REVERSE{$packed} = sprintf '\u%.4X', $_ unless defined $REVERSE{$packed};
40             }
41              
42             sub decode_json {
43 72     72 1 36206 my $err = _decode(\my $value, shift);
44 72 100       1921 return defined $err ? croak $err : $value;
45             }
46              
47 57     57 1 24489 sub encode_json { Encode::encode 'UTF-8', _encode_value(shift) }
48              
49 8     8 1 467 sub false () {$FALSE} ## no critic (prototypes)
50              
51             sub from_json {
52 3     3 1 463 my $err = _decode(\my $value, shift, 1);
53 3 100       91 return defined $err ? croak $err : $value;
54             }
55              
56             sub j {
57 5 100 66 5 1 2188 return encode_json $_[0] if ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH';
58 4         16 return decode_json $_[0];
59             }
60              
61 2     2 1 6 sub to_json { _encode_value(shift) }
62              
63 10     10 1 2336 sub true () {$TRUE} ## no critic (prototypes)
64              
65             sub _decode {
66 75     75   110 my $valueref = shift;
67              
68 75 100       116 eval {
69              
70             # Missing input
71 75 100       205 die "Missing or empty input\n" unless length( local $_ = shift );
72              
73             # UTF-8
74 74 100       135 $_ = eval { Encode::decode('UTF-8', $_, 1) } unless shift;
  71         168  
75 74 100       3483 die "Input is not UTF-8 encoded\n" unless defined $_;
76              
77             # Value
78 72         122 $$valueref = _decode_value();
79              
80             # Leftover data
81 58   66     286 return m/\G[\x20\x09\x0a\x0d]*\z/gc || _throw('Unexpected data');
82             } ? return undef : chomp $@;
83              
84 22         45 return $@;
85             }
86              
87             sub _decode_array {
88 54     54   67 my @array;
89 54         459 until (m/\G[\x20\x09\x0a\x0d]*\]/gc) {
90              
91             # Value
92 75         127 push @array, _decode_value();
93              
94             # Separator
95 70 100       168 redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
96              
97             # End
98 44 100       125 last if m/\G[\x20\x09\x0a\x0d]*\]/gc;
99              
100             # Invalid character
101 3         9 _throw('Expected comma or right square bracket while parsing array');
102             }
103              
104 46         102 return \@array;
105             }
106              
107             sub _decode_object {
108 20     20   32 my %hash;
109 20         74 until (m/\G[\x20\x09\x0a\x0d]*\}/gc) {
110              
111             # Quote
112 28 100       78 m/\G[\x20\x09\x0a\x0d]*"/gc
113             or _throw('Expected string while parsing object');
114              
115             # Key
116 25         38 my $key = _decode_string();
117              
118             # Colon
119 25 100       71 m/\G[\x20\x09\x0a\x0d]*:/gc
120             or _throw('Expected colon while parsing object');
121              
122             # Value
123 24         40 $hash{$key} = _decode_value();
124              
125             # Separator
126 24 100       67 redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
127              
128             # End
129 14 100       40 last if m/\G[\x20\x09\x0a\x0d]*\}/gc;
130              
131             # Invalid character
132 1         3 _throw('Expected comma or right curly bracket while parsing object');
133             }
134              
135 15         35 return \%hash;
136             }
137              
138             sub _decode_string {
139 71     71   128 my $pos = pos;
140            
141             # Extract string with escaped characters
142 71         10304 m!\G((?:(?:[^\x00-\x1f\\"]|\\(?:["\\/bfnrt]|u[0-9a-fA-F]{4})){0,32766})*)!gc; # segfault on 5.8.x in t/20-mojo-json.t
143 71         160 my $str = $1;
144              
145             # Invalid character
146 71 100       164 unless (m/\G"/gc) {
147 2 100       8 _throw('Unexpected character or invalid escape while parsing string')
148             if m/\G[\x00-\x1f\\]/;
149 1         3 _throw('Unterminated string');
150             }
151              
152             # Unescape popular characters
153 69 100       179 if (index($str, '\\u') < 0) {
154 63         255 $str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
155 63         143 return $str;
156             }
157              
158             # Unescape everything else
159 6         11 my $buffer = '';
160 6         32 while ($str =~ m/\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
161 13         26 $buffer .= $1;
162              
163             # Popular character
164 13 100       27 if ($2) { $buffer .= $ESCAPE{$2} }
  5         33  
165              
166             # Escaped
167             else {
168 8         25 my $ord = hex $3;
169              
170             # Surrogate pair
171 8 100       24 if (($ord & 0xf800) == 0xd800) {
172              
173             # High surrogate
174 3 100       15 ($ord & 0xfc00) == 0xd800
175             or pos($_) = $pos + pos($str), _throw('Missing high-surrogate');
176              
177             # Low surrogate
178 2 100       12 $str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
179             or pos($_) = $pos + pos($str), _throw('Missing low-surrogate');
180              
181 1         5 $ord = 0x10000 + ($ord - 0xd800) * 0x400 + (hex($1) - 0xdc00);
182             }
183              
184             # Character
185 6         38 $buffer .= pack 'U', $ord;
186             }
187             }
188              
189             # The rest
190 4         24 return $buffer . substr $str, pos $str, length $str;
191             }
192              
193             sub _decode_value {
194              
195             # Leading whitespace
196 171     171   402 m/\G[\x20\x09\x0a\x0d]*/gc;
197              
198             # String
199 171 100       337 return _decode_string() if m/\G"/gc;
200              
201             # Object
202 125 100       221 return _decode_object() if m/\G\{/gc;
203              
204             # Array
205 105 100       210 return _decode_array() if m/\G\[/gc;
206              
207             # Number
208 51         157 my ($i) = /\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
209 51 100       140 return 0 + $i if defined $i;
210              
211             # True
212 22 100       49 return $TRUE if m/\Gtrue/gc;
213              
214             # False
215 14 100       54 return $FALSE if m/\Gfalse/gc;
216              
217             # Null
218 7 100       23 return undef if m/\Gnull/gc; ## no critic (return)
219              
220             # Invalid character
221 2         5 _throw('Expected string, array, object, number, boolean or null');
222             }
223              
224             sub _encode_array {
225 44     44   51 '[' . join(',', map { _encode_value($_) } @{$_[0]}) . ']';
  58         87  
  44         103  
226             }
227              
228             sub _encode_object {
229 25     25   36 my $object = shift;
230 25         90 my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) }
  24         43  
231             sort keys %$object;
232 25         114 return '{' . join(',', @pairs) . '}';
233             }
234              
235             sub _encode_string {
236 55     55   69 my $str = shift;
237 55         275 $str =~ s!([\x00-\x1f\x{2028}\x{2029}\\"/])!$REVERSE{$1}!gs;
238 55         316 return "\"$str\"";
239             }
240              
241             sub _encode_value {
242 143     143   201 my $value = shift;
243              
244             # Reference
245 143 100       263 if (my $ref = ref $value) {
246              
247             # Object
248 88 100       169 return _encode_object($value) if $ref eq 'HASH';
249              
250             # Array
251 63 100       122 return _encode_array($value) if $ref eq 'ARRAY';
252              
253             # True or false
254 19 100       57 return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
    100          
255 11 100       29 return $value ? 'true' : 'false' if $ref eq 'JSON::Tiny::_Bool';
    100          
256              
257             # Blessed reference with TO_JSON method
258 2 50 33     22 if (blessed $value && (my $sub = $value->can('TO_JSON'))) {
259 2         5 return _encode_value($value->$sub);
260             }
261             }
262              
263             # Null
264 55 100       106 return 'null' unless defined $value;
265              
266              
267             # Number (bitwise operators change behavior based on the internal value type)
268              
269 50 100 100     391 return $value
      100        
270             if B::svref_2object(\$value)->FLAGS & (B::SVp_IOK | B::SVp_NOK)
271             # filter out "upgraded" strings whose numeric form doesn't strictly match
272             && 0 + $value eq $value
273             # filter out inf and nan
274             && $value * 0 == 0;
275              
276             # String
277 31         66 return _encode_string($value);
278             }
279              
280             sub _throw {
281              
282             # Leading whitespace
283 19     19   43 m/\G[\x20\x09\x0a\x0d]*/gc;
284              
285             # Context
286 19         39 my $context = 'Malformed JSON: ' . shift;
287 19 50       42 if (m/\G\z/gc) { $context .= ' before end of data' }
  0         0  
288             else {
289 19         75 my @lines = split "\n", substr($_, 0, pos);
290 19   100     71 $context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
291             }
292              
293 19         106 die "$context\n";
294             }
295              
296             # Emulate boolean type
297             package JSON::Tiny::_Bool;
298 4     4   3453 use overload '""' => sub { ${$_[0]} }, fallback => 1;
  4     40   3333  
  4         30  
  40         2324  
  40         353  
299             1;