File Coverage

blib/lib/Mojo/JSON.pm
Criterion Covered Total %
statement 120 122 98.3
branch 81 82 98.7
condition 14 14 100.0
subroutine 25 25 100.0
pod 7 7 100.0
total 247 250 98.8


line stmt bran cond sub pod time code
1             package Mojo::JSON;
2 71     71   128776 use Mojo::Base -strict;
  71         157  
  71         472  
3              
4 71     71   493 use Carp qw(croak);
  71         170  
  71         3510  
5 71     71   456 use Exporter qw(import);
  71         167  
  71         2083  
6 71     71   54587 use JSON::PP ();
  71         1031934  
  71         2367  
7 71     71   534 use Mojo::Util qw(decode encode monkey_patch);
  71         169  
  71         6407  
8 71     71   482 use Scalar::Util qw(blessed);
  71         181  
  71         6807  
9              
10             # For better performance Cpanel::JSON::XS is required
11             use constant JSON_XS => $ENV{MOJO_NO_JSON_XS}
12             ? 0
13 71 100   71   484 : !!eval { require Cpanel::JSON::XS; Cpanel::JSON::XS->VERSION('4.09'); 1 };
  71         155  
  71         3105  
  70         64974  
  70         410433  
  0         0  
14              
15             our @EXPORT_OK = qw(decode_json encode_json false from_json j to_json true);
16              
17             # Escaped special character map
18             my %ESCAPE
19             = ('"' => '"', '\\' => '\\', '/' => '/', 'b' => "\x08", 'f' => "\x0c", 'n' => "\x0a", 'r' => "\x0d", 't' => "\x09");
20             my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
21             for (0x00 .. 0x1f) { $REVERSE{pack 'C', $_} //= sprintf '\u%.4X', $_ }
22              
23             # Replace pure-Perl fallbacks if Cpanel::JSON::XS is available
24             if (JSON_XS) {
25             my $BINARY = Cpanel::JSON::XS->new->utf8;
26             my $TEXT = Cpanel::JSON::XS->new;
27             $_->canonical->allow_nonref->allow_unknown->allow_blessed->convert_blessed->stringify_infnan->escape_slash
28             ->allow_dupkeys
29             for $BINARY, $TEXT;
30             monkey_patch __PACKAGE__, 'encode_json', sub { $BINARY->encode($_[0]) };
31             monkey_patch __PACKAGE__, 'decode_json', sub { $BINARY->decode($_[0]) };
32             monkey_patch __PACKAGE__, 'to_json', sub { $TEXT->encode($_[0]) };
33             monkey_patch __PACKAGE__, 'from_json', sub { $TEXT->decode($_[0]) };
34             }
35              
36             sub decode_json {
37 189     189 1 83864 my $err = _decode(\my $value, shift);
38 189 100       3089 return defined $err ? croak $err : $value;
39             }
40              
41 182     182 1 58506 sub encode_json { encode('UTF-8', _encode_value(shift)) }
42              
43 17     17 1 2231 sub false () {JSON::PP::false}
44              
45             sub from_json {
46 11     11 1 3176 my $err = _decode(\my $value, shift, 1);
47 11 100       408 return defined $err ? croak $err : $value;
48             }
49              
50             sub j {
51 94 100 100 94 1 9785 return encode_json($_[0]) if ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH';
52 91         184 return scalar eval { decode_json($_[0]) };
  91         278  
53             }
54              
55 2     2 1 8 sub to_json { _encode_value(shift) }
56              
57 18     18 1 7222 sub true () {JSON::PP::true}
58              
59             sub _decode {
60 200     200   370 my $valueref = shift;
61              
62 200 100       355 eval {
63              
64             # Missing input
65 200 100       679 die "Missing or empty input at offset 0\n" unless length(local $_ = shift);
66              
67             # UTF-8
68 199 100       773 $_ = decode('UTF-8', $_) unless shift;
69 199 100       679 die "Input is not UTF-8 encoded\n" unless defined;
70              
71             # Value
72 197         591 $$valueref = _decode_value();
73              
74             # Leftover data
75 183 100       1295 /\G[\x20\x09\x0a\x0d]*\z/gc or _throw('Unexpected data');
76             } ? return undef : chomp $@;
77              
78 22         60 return $@;
79             }
80              
81             sub _decode_array {
82 77     77   126 my @array;
83 77         657 until (m/\G[\x20\x09\x0a\x0d]*\]/gc) {
84              
85             # Value
86 153         309 push @array, _decode_value();
87              
88             # Separator
89 148 100       485 redo if /\G[\x20\x09\x0a\x0d]*,/gc;
90              
91             # End
92 68 100       250 last if /\G[\x20\x09\x0a\x0d]*\]/gc;
93              
94             # Invalid character
95 2         71 _throw('Expected comma or right square bracket while parsing array');
96             }
97              
98 70         191 return \@array;
99             }
100              
101             sub _decode_object {
102 132     132   240 my %hash;
103 132         746 until (m/\G[\x20\x09\x0a\x0d]*\}/gc) {
104              
105             # Quote
106 197 100       856 /\G[\x20\x09\x0a\x0d]*"/gc or _throw('Expected string while parsing object');
107              
108             # Key
109 194         433 my $key = _decode_string();
110              
111             # Colon
112 194 100       764 /\G[\x20\x09\x0a\x0d]*:/gc or _throw('Expected colon while parsing object');
113              
114             # Value
115 193         455 $hash{$key} = _decode_value();
116              
117             # Separator
118 193 100       797 redo if /\G[\x20\x09\x0a\x0d]*,/gc;
119              
120             # End
121 125 100       575 last if /\G[\x20\x09\x0a\x0d]*\}/gc;
122              
123             # Invalid character
124 1         14 _throw('Expected comma or right curly bracket while parsing object');
125             }
126              
127 127         384 return \%hash;
128             }
129              
130             sub _decode_string {
131 346     346   1152 my $pos = pos;
132              
133             # Extract string with escaped characters
134 346         22060 m!\G((?:(?:[^\x00-\x1f\\"]|\\(?:["\\/bfnrt]|u[0-9a-fA-F]{4})){0,32766})*)!gc;
135 346         831 my $str = $1;
136              
137             # Invalid character
138 346 100       1043 unless (m/\G"/gc) {
139 2 100       11 _throw('Unexpected character or invalid escape while parsing string') if /\G[\x00-\x1f\\]/;
140 1         3 _throw('Unterminated string');
141             }
142              
143             # Unescape popular characters
144 344 100       1121 if (index($str, '\\u') < 0) {
145 339         1453 $str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
146 339         981 return $str;
147             }
148              
149             # Unescape everything else
150 5         12 my $buffer = '';
151 5         27 while ($str =~ /\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
152 10         23 $buffer .= $1;
153              
154             # Popular character
155 10 100       26 if ($2) { $buffer .= $ESCAPE{$2} }
  4         19  
156              
157             # Escaped
158             else {
159 6         24 my $ord = hex $3;
160              
161             # Surrogate pair
162 6 100       17 if (($ord & 0xf800) == 0xd800) {
163              
164             # High surrogate
165 3 100       15 ($ord & 0xfc00) == 0xd800 or pos = $pos + pos($str), _throw('Missing high-surrogate');
166              
167             # Low surrogate
168 2 100       13 $str =~ /\G\\u([Dd][C-Fc-f]..)/gc or pos = $pos + pos($str), _throw('Missing low-surrogate');
169              
170 1         4 $ord = 0x10000 + ($ord - 0xd800) * 0x400 + (hex($1) - 0xdc00);
171             }
172              
173             # Character
174 4         29 $buffer .= pack 'U', $ord;
175             }
176             }
177              
178             # The rest
179 3         20 return $buffer . substr $str, pos($str), length($str);
180             }
181              
182             sub _decode_value {
183              
184             # Leading whitespace
185 543     543   1566 /\G[\x20\x09\x0a\x0d]*/gc;
186              
187             # String
188 543 100       1488 return _decode_string() if /\G"/gc;
189              
190             # Object
191 391 100       1197 return _decode_object() if /\G\{/gc;
192              
193             # Array
194 259 100       693 return _decode_array() if /\G\[/gc;
195              
196             # Number
197 182 100       998 return 0 + $1 if /\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
198              
199             # True
200 25 100       98 return true() if /\Gtrue/gc;
201              
202             # False
203 19 100       65 return false() if /\Gfalse/gc;
204              
205             # Null
206 13 100       59 return undef if /\Gnull/gc;
207              
208             # Invalid character
209 3         13 _throw('Expected string, array, object, number, boolean or null');
210             }
211              
212             sub _encode_array {
213 63     63   103 '[' . join(',', map { _encode_value($_) } @{$_[0]}) . ']';
  114         291  
  63         179  
214             }
215              
216             sub _encode_object {
217 135     135   291 my $object = shift;
218 135         571 my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) } sort keys %$object;
  201         559  
219 135         881 return '{' . join(',', @pairs) . '}';
220             }
221              
222             sub _encode_string {
223 348     348   553 my $str = shift;
224 348         992 $str =~ s!([\x00-\x1f\\"/])!$REVERSE{$1}!gs;
225 348         1771 return "\"$str\"";
226             }
227              
228             sub _encode_value {
229 502     502   828 my $value = shift;
230              
231             # Reference
232 502 100       1232 if (my $ref = ref $value) {
233              
234             # Object
235 219 100       782 return _encode_object($value) if $ref eq 'HASH';
236              
237             # Array
238 84 100       234 return _encode_array($value) if $ref eq 'ARRAY';
239              
240             # True or false
241 21 100       73 return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
    100          
242 16 100       52 return $value ? 'true' : 'false' if $ref eq 'JSON::PP::Boolean';
    100          
243              
244             # Everything else
245 7 100       31 return 'null' unless blessed $value;
246 6 100       72 return _encode_string($value) unless my $sub = $value->can('TO_JSON');
247 3         14 return _encode_value($value->$sub);
248             }
249              
250             # Null
251 283 100       696 return 'null' unless defined $value;
252              
253             # Number
254 71     71   848 no warnings 'numeric';
  71         180  
  71         24819  
255 274 100 100     2452 return $value
      100        
      100        
256             if !utf8::is_utf8($value) && length((my $dummy = '') & $value) && 0 + $value eq $value && $value * 0 == 0;
257              
258             # String
259 144         332 return _encode_string($value);
260             }
261              
262             sub _throw {
263              
264             # Leading whitespace
265 19     19   45 /\G[\x20\x09\x0a\x0d]*/gc;
266              
267             # Context
268 19         54 my $context = 'Malformed JSON: ' . shift;
269 19 50       53 if (m/\G\z/gc) { $context .= ' before end of data' }
  0         0  
270             else {
271 19         82 my @lines = split /\n/, substr($_, 0, pos);
272 19   100     88 $context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
273             }
274              
275 19         126 die "$context\n";
276             }
277              
278             1;
279              
280             =encoding utf8
281              
282             =head1 NAME
283              
284             Mojo::JSON - Minimalistic JSON
285              
286             =head1 SYNOPSIS
287              
288             use Mojo::JSON qw(decode_json encode_json);
289              
290             my $bytes = encode_json {foo => [1, 2], bar => 'hello!', baz => \1};
291             my $hash = decode_json $bytes;
292              
293             =head1 DESCRIPTION
294              
295             L is a minimalistic and possibly the fastest pure-Perl implementation of L
296             8259|https://tools.ietf.org/html/rfc8259>.
297              
298             It supports normal Perl data types like scalar, array reference, hash reference and will try to call the C
299             method on blessed references, or stringify them if it doesn't exist. Differentiating between strings and numbers in
300             Perl is hard, depending on how it has been used, a scalar can be both at the same time. The string value has a higher
301             precedence unless both representations are equivalent.
302              
303             [1, -2, 3] -> [1, -2, 3]
304             {"foo": "bar"} -> {foo => 'bar'}
305              
306             Literal names will be translated to and from L constants or a similar native Perl value.
307              
308             true -> Mojo::JSON->true
309             false -> Mojo::JSON->false
310             null -> undef
311              
312             In addition scalar references will be used to generate booleans, based on if their values are true or false.
313              
314             \1 -> true
315             \0 -> false
316              
317             The character C will always be escaped to prevent XSS attacks.
318              
319             "" -> "<\/script>"
320              
321             For better performance the optional module L (4.09+) will be used automatically if possible. This can
322             also be disabled with the C environment variable.
323              
324             =head1 FUNCTIONS
325              
326             L implements the following functions, which can be imported individually.
327              
328             =head2 decode_json
329              
330             my $value = decode_json $bytes;
331              
332             Decode JSON to Perl value and die if decoding fails.
333              
334             =head2 encode_json
335              
336             my $bytes = encode_json {i => '♥ mojolicious'};
337              
338             Encode Perl value to JSON.
339              
340             =head2 false
341              
342             my $false = false;
343              
344             False value, used because Perl has no native equivalent.
345              
346             =head2 from_json
347              
348             my $value = from_json $chars;
349              
350             Decode JSON text that is not C encoded to Perl value and die if decoding fails.
351              
352             =head2 j
353              
354             my $bytes = j [1, 2, 3];
355             my $bytes = j {i => '♥ mojolicious'};
356             my $value = j $bytes;
357              
358             Encode Perl data structure (which may only be an array reference or hash reference) or decode JSON, an C return
359             value indicates a bare C or that decoding failed.
360              
361             =head2 to_json
362              
363             my $chars = to_json {i => '♥ mojolicious'};
364              
365             Encode Perl value to JSON text without C encoding it.
366              
367             =head2 true
368              
369             my $true = true;
370              
371             True value, used because Perl has no native equivalent.
372              
373             =head1 SEE ALSO
374              
375             L, L, L.
376              
377             =cut