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