File Coverage

blib/lib/JSON/Tiny/Subclassable.pm
Criterion Covered Total %
statement 139 202 68.8
branch 58 114 50.8
condition 5 20 25.0
subroutine 30 35 85.7
pod 8 9 88.8
total 240 380 63.1


line stmt bran cond sub pod time code
1 4     4   37535 use 5.008;
  4         14  
  4         197  
2 4     4   26 use strict;
  4         7  
  4         198  
3 4     4   21 use warnings;
  4         7  
  4         353  
4              
5             {
6             package JSON::Tiny::Subclassable;
7              
8             our $AUTHORITY = 'cpan:TOBYINK';
9             our $VERSION = '0.004';
10             our @ISA = qw(JSON::Tiny);
11            
12 4     4   19 use B;
  4         9  
  4         212  
13 4     4   5377 use Encode ();
  4         55166  
  4         101  
14 4     4   40 use Scalar::Util ();
  4         121  
  4         200  
15            
16             BEGIN {
17 4 50   4 0 10 eval { require Sub::Name; Sub::Name->import('subname'); 1 }
  4     11   3204  
  0         0  
  0         0  
  11         34  
18             or eval q{ sub subname { $_[1] } };
19             };
20            
21             sub new {
22 5     5 1 46 my $class = shift;
23 5 50       40 bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, $class;
  0 100       0  
24             }
25            
26             sub error {
27 5 50   5 1 44 $_[0]->{error} = $_[1] if @_ > 1;
28 5         12 return $_[0]->{error};
29             }
30            
31             sub pretty {
32 3 50   3 1 19 $_[0]->{pretty} = $_[1] if @_ > 1;
33 3         22 return $_[0]->{pretty};
34             }
35            
36             sub import {
37 14     14   60 my $class = shift;
38 14         32 my $caller = caller;
39 14         24 my $opts = {};
40 14         51 while (@_) {
41 11         18 my $arg = shift;
42 11 100       64 $opts->{$arg} = ref $_[0] ? shift @_ : undef;
43             }
44 14 100       4261 if (exists $opts->{'j'}) {
45 11   100     83 my $func = ((ref $opts->{j} eq 'HASH') && $opts->{j}{-as}) || 'j';
46 4     4   23 no strict 'refs';
  4         8  
  4         12712  
47 11         64 *{"$caller\::$func"} = subname "$class\::j" => sub {
48 3     3   1506 my $d = shift;
49 3 50 33     23 return $class->new->encode($d) if ref $d eq 'ARRAY' || ref $d eq 'HASH';
50 3         21 return $class->new->decode($d);
51 11         488 };
52 11         1940 delete $opts->{'j'};
53             }
54             }
55            
56             __PACKAGE__->import('j');
57            
58             # Literal names
59             my $FALSE = bless \(my $false = 0), 'JSON::Tiny::_Bool';
60             my $TRUE = bless \(my $true = 1), 'JSON::Tiny::_Bool';
61            
62             # Escaped special character map (with u2028 and u2029)
63             my %ESCAPE = (
64             '"' => '"',
65             '\\' => '\\',
66             '/' => '/',
67             'b' => "\x07",
68             'f' => "\x0C",
69             'n' => "\x0A",
70             'r' => "\x0D",
71             't' => "\x09",
72             'u2028' => "\x{2028}",
73             'u2029' => "\x{2029}"
74             );
75             my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
76             for (0x00 .. 0x1F, 0x7F) {
77             my $k = pack 'C', $_;
78             $REVERSE{$k} = sprintf '\u%.4X', $_ unless defined $REVERSE{$k};
79             }
80            
81             # Unicode encoding detection
82             my $UTF_PATTERNS = {
83             'UTF-32BE' => qr/^\0\0\0[^\0]/,
84             'UTF-16BE' => qr/^\0[^\0]\0[^\0]/,
85             'UTF-32LE' => qr/^[^\0]\0\0\0/,
86             'UTF-16LE' => qr/^[^\0]\0[^\0]\0/
87             };
88            
89             my $WHITESPACE_RE = qr/[\x20\x09\x0a\x0d]*/;
90            
91             sub DOES {
92 0     0 1 0 my ($proto, $role) = @_;
93 0 0       0 return 1 if $role eq 'Mojo::JSON';
94 0         0 return $proto->SUPER::DOES($role);
95             }
96            
97             sub decode {
98 5     5 1 876 my ($self, $bytes) = @_;
99            
100             # Cleanup
101 5         28 $self->error(undef);
102            
103             # Missing input
104 5 50 0     18 $self->error('Missing or empty input') and return undef unless $bytes; ## no critic (undef)
105            
106             # Remove BOM
107 5         12 $bytes =~ s/^(?:\357\273\277|\377\376\0\0|\0\0\376\377|\376\377|\377\376)//g;
108            
109             # Wide characters
110 5 50 0     22 $self->error('Wide character in input') and return undef ## no critic (undef)
111             unless utf8::downgrade($bytes, 1);
112            
113             # Detect and decode Unicode
114 5         8 my $encoding = 'UTF-8';
115 5   33     98 $bytes =~ $UTF_PATTERNS->{$_} and $encoding = $_ for keys %$UTF_PATTERNS;
116            
117 5         13 my $d_res = eval { $bytes = Encode::decode($encoding, $bytes, 1); 1 };
  5         25  
  5         760  
118 5 50       19 $bytes = undef unless $d_res;
119            
120             # Object or array
121 5         10 my $res = eval {
122 5         10 local $_ = $bytes;
123            
124             # Leading whitespace
125 5         111 m/\G$WHITESPACE_RE/gc;
126            
127             # Array
128 5         11 my $ref;
129 5 50       39 if (m/\G\[/gc) { $ref = $self->_decode_array() }
  0 50       0  
130            
131             # Object
132 5         28 elsif (m/\G\{/gc) { $ref = $self->_decode_object() }
133            
134             # Unexpected
135 0         0 else { $self->_exception('Expected array or object') }
136            
137             # Leftover data
138 5 50       69 unless (m/\G$WHITESPACE_RE\z/gc) {
139 0 0       0 my $got = ref $ref eq 'ARRAY' ? 'array' : 'object';
140 0         0 $self->_exception("Unexpected data after $got");
141             }
142            
143 5         16 $ref;
144             };
145            
146             # Exception
147 5 50 33     33 if (!$res && (my $e = $@)) {
148 0         0 chomp $e;
149 0         0 $self->error($e);
150             }
151            
152 5         28 return $res;
153             }
154            
155             sub encode {
156 2     2 1 5 my ($self, $ref) = @_;
157            
158 2         4 my $eof = '';
159 2 100       10 if ($self->pretty) {
160 1         2 $self->{_indent} = '';
161 1         6 $eof .= "\n";
162             }
163            
164 2         51 return Encode::encode 'UTF-8', $self->_encode_values($ref).$eof;
165             }
166            
167 1     1 1 6 sub false {$FALSE}
168 1     1 1 5 sub true {$TRUE}
169            
170 1     1   3 sub _new_hash { +{} }
171 3     3   10 sub _new_array { +[] }
172            
173             sub _decode_array {
174 3     3   3 my $self = shift;
175 3         9 my $array = $self->_new_array;
176 3         32 until (m/\G$WHITESPACE_RE\]/gc) {
177            
178             # Value
179 4         10 push @$array, $self->_decode_value();
180            
181             # Separator
182 4 100       39 redo if m/\G$WHITESPACE_RE,/gc;
183            
184             # End
185 2 50       30 last if m/\G$WHITESPACE_RE\]/gc;
186            
187             # Invalid character
188 0         0 $self->_exception('Expected comma or right square bracket while parsing array');
189             }
190            
191 3         21 return $array;
192             }
193            
194             sub _decode_object {
195 7     7   14 my $self = shift;
196 7         29 my $hash = $self->_new_hash;
197 7         103 until (m/\G$WHITESPACE_RE\}/gc) {
198            
199             # Quote
200 20 50       141 m/\G$WHITESPACE_RE"/gc
201             or $self->_exception('Expected string while parsing object');
202            
203             # Key
204 20         56 my $key = $self->_decode_string();
205            
206             # Colon
207 20 50       160 m/\G$WHITESPACE_RE:/gc
208             or $self->_exception('Expected colon while parsing object');
209            
210             # Value
211 20         58 $hash->{$key} = $self->_decode_value();
212            
213             # Separator
214 20 100       165 redo if m/\G$WHITESPACE_RE,/gc;
215            
216             # End
217 6 50       91 last if m/\G$WHITESPACE_RE\}/gc;
218            
219             # Invalid character
220 0         0 $self->_exception('Expected comma or right curly bracket while parsing object');
221             }
222            
223 7         22 return $hash;
224             }
225            
226             sub _decode_string {
227 20     20   27 my $self = shift;
228 20         59 my $pos = pos;
229            
230             # Extract string with escaped characters
231 20         70 m#\G(((?:[^\x00-\x1F\\"]|\\(?:["\\/bfnrt]|u[[:xdigit:]]{4})){0,32766})*)#gc;
232 20         39 my $str = $1;
233            
234             # Missing quote
235 20 50       59 unless (m/\G"/gc) {
236 0 0       0 $self->_exception('Unexpected character or invalid escape while parsing string')
237             if m/\G[\x00-\x1F\\]/;
238 0         0 $self->_exception('Unterminated string');
239             }
240            
241             # Unescape popular characters
242 20 50       64 if (index($str, '\\u') < 0) {
243 20         36 $str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
244 20         43 return $str;
245             }
246            
247             # Unescape everything else
248 0         0 my $buffer = '';
249 0         0 while ($str =~ m/\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
250 0         0 $buffer .= $1;
251            
252             # Popular character
253 0 0       0 if ($2) { $buffer .= $ESCAPE{$2} }
  0         0  
254            
255             # Escaped
256             else {
257 0         0 my $ord = hex $3;
258            
259             # Surrogate pair
260 0 0       0 if (($ord & 0xF800) == 0xD800) {
261            
262             # High surrogate
263 0 0       0 ($ord & 0xFC00) == 0xD800
264             or pos($_) = $pos + pos($str), $self->_exception('Missing high-surrogate');
265            
266             # Low surrogate
267 0 0       0 $str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
268             or pos($_) = $pos + pos($str), $self->_exception('Missing low-surrogate');
269            
270             # Pair
271 0         0 $ord = 0x10000 + ($ord - 0xD800) * 0x400 + (hex($1) - 0xDC00);
272             }
273            
274             # Character
275 0         0 $buffer .= pack 'U', $ord;
276             }
277             }
278            
279             # The rest
280 0         0 return $buffer . substr $str, pos($str), length($str);
281             }
282            
283             sub _decode_value {
284 24     24   38 my $self = shift;
285            
286             # Leading whitespace
287 24         113 m/\G$WHITESPACE_RE/gc;
288            
289             # String
290 24 50       69 return $self->_decode_string() if m/\G"/gc;
291            
292             # Array
293 24 100       58 return $self->_decode_array() if m/\G\[/gc;
294            
295             # Object
296 21 100       63 return $self->_decode_object() if m/\G\{/gc;
297            
298             # Number
299 19 100       153 return 0 + $1
300             if m/\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
301            
302             # True
303 3 100       12 return $self->true if m/\Gtrue/gc;
304            
305             # False
306 2 100       12 return $self->false if m/\Gfalse/gc;
307            
308             # Null
309 1 50       8 return undef if m/\Gnull/gc; ## no critic (return)
310            
311             # Invalid data
312 0         0 $self->_exception('Expected string, array, object, number, boolean or null');
313             }
314            
315             sub _encode_array {
316 3     3   4 my $self = shift;
317            
318 3 100       12 return "[]" unless @{$_[0]};
  3         17  
319            
320 2 50       6 return '[' . join(',', map { $self->_encode_values($_) } @{shift()}) . ']'
  0         0  
  0         0  
321             unless exists $self->{_indent};
322            
323 2         4 my $indent = $self->{_indent};
324 4         9 return "\[\n$indent\t"
325             . join(",\n$indent\t", map {
326 4         8 local $self->{_indent} = "$indent\t"; $self->_encode_values($_)
  2         3  
327 2         6 } @{shift()})
328             . "\n$indent\]";
329             }
330            
331             sub _encode_object {
332 0     0   0 my $self = shift;
333 0         0 my $object = shift;
334            
335 0         0 my $indent;
336 0 0       0 if (exists $self->{_indent}) {
337 0         0 $indent = $self->{_indent};
338 0         0 $self->{_indent} .= "\t";
339             }
340            
341             # Encode pairs
342 0         0 my @pairs;
343 0 0       0 my $space = defined $indent ? q( ) : q();
344 0         0 while (my ($k, $v) = each %$object) {
345 0         0 push @pairs, sprintf(
346             '%s:%s%s',
347             $self->_encode_string($k),
348             $space,
349             $self->_encode_values($v),
350             );
351             }
352            
353 0 0       0 if (defined $indent)
354             {
355 0         0 $self->{_indent} =~ s/^.//;
356 0 0       0 return "{}" unless @pairs;
357 0         0 return "\{\n$indent\t" . join(",\n$indent\t", @pairs) . "\n$indent\}";
358             }
359             else
360             {
361 0         0 return '{' . join(',', @pairs) . '}';
362             }
363             }
364            
365             sub _encode_string {
366 14     14   15 my $self = shift;
367 14         17 my $string = shift;
368            
369             # Escape string
370 14         41 $string =~ s!([\x00-\x1F\x7F\x{2028}\x{2029}\\"/\b\f\n\r\t])!$REVERSE{$1}!gs;
371            
372             # Stringify
373 14         58 return "\"$string\"";
374             }
375            
376             sub _encode_values {
377 20     20   24 my $self = shift;
378 20         21 my $value = shift;
379            
380             # Reference
381 20 100       44 if (my $ref = ref $value) {
382            
383             # Array
384 9 100       31 return $self->_encode_array($value) if $ref eq 'ARRAY';
385            
386             # Object
387 6 100       29 return $self->_encode_object($value) if $ref eq 'HASH';
388            
389             # True or false
390 2 0       3 return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
    50          
391 2 100       9 return $value ? 'true' : 'false' if $ref eq 'JSON::Tiny::_Bool';
    50          
392            
393             # Blessed reference with TO_JSON method
394 0 0 0     0 if (Scalar::Util::blessed $value && (my $sub = $value->can('TO_JSON'))) {
395 0         0 return $self->_encode_values($value->$sub);
396             }
397             }
398            
399             # Null
400 11 100       26 return 'null' unless defined $value;
401            
402             # Number
403 10 50       172 return 0 + $value
404             if B::svref_2object(\$value)->FLAGS & (B::SVp_IOK | B::SVp_NOK);
405            
406             # String
407 0           return $self->_encode_string($value);
408             }
409            
410             sub _exception {
411 0     0     my $self = shift;
412            
413             # Leading whitespace
414 0           m/\G$WHITESPACE_RE/gc;
415            
416             # Context
417 0           my $context = 'Malformed JSON: ' . shift;
418 0 0         if (m/\G\z/gc) { $context .= ' before end of data' }
  0            
419             else {
420 0           my @lines = split /\n/, substr($_, 0, pos);
421 0   0       $context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
422             }
423            
424             # Throw
425 0           die "$context\n";
426             }
427             }
428              
429             {
430             package JSON::Tiny::_Bool;
431 4     4   38 no warnings;
  4         24  
  4         474  
432             use overload
433 4     4   4 '0+' => sub { ${$_[0]} },
  4         20  
434 0     0   0 '""' => sub { ${$_[0]} },
  0         0  
435 4         55 fallback => 1,
436 4     4   7690 ;
  4         4768  
437             sub DOES {
438 0     0     my ($proto, $role) = @_;
439 0 0         return 1 if $role eq 'Mojo::JSON::_Bool';
440 0 0         return 1 if $role =~ /^JSON::(?:PP::|XS::)?Boolean$/;
441 0           return $proto->SUPER::DOES($role);
442             }
443             }
444              
445             1;
446              
447             __END__