300 lines
6.5 KiB
Perl
300 lines
6.5 KiB
Perl
package JSON::Tiny;
|
|
|
|
# Minimalistic JSON. Adapted from Mojo::JSON. (c)2012-2015 David Oswald
|
|
# License: Artistic 2.0 license.
|
|
# http://www.perlfoundation.org/artistic_license_2_0
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Carp 'croak';
|
|
use Exporter 'import';
|
|
use Scalar::Util 'blessed';
|
|
use Encode ();
|
|
use B;
|
|
|
|
our $VERSION = '0.58';
|
|
our @EXPORT_OK = qw(decode_json encode_json false from_json j to_json true);
|
|
|
|
# Literal names
|
|
# Users may override Booleans with literal 0 or 1 if desired.
|
|
our($FALSE, $TRUE) = map { bless \(my $dummy = $_), 'JSON::Tiny::_Bool' } 0, 1;
|
|
|
|
# Escaped special character map with u2028 and u2029
|
|
my %ESCAPE = (
|
|
'"' => '"',
|
|
'\\' => '\\',
|
|
'/' => '/',
|
|
'b' => "\x08",
|
|
'f' => "\x0c",
|
|
'n' => "\x0a",
|
|
'r' => "\x0d",
|
|
't' => "\x09",
|
|
'u2028' => "\x{2028}",
|
|
'u2029' => "\x{2029}"
|
|
);
|
|
my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
|
|
|
|
for(0x00 .. 0x1f) {
|
|
my $packed = pack 'C', $_;
|
|
$REVERSE{$packed} = sprintf '\u%.4X', $_ unless defined $REVERSE{$packed};
|
|
}
|
|
|
|
sub decode_json {
|
|
my $err = _decode(\my $value, shift);
|
|
return defined $err ? croak $err : $value;
|
|
}
|
|
|
|
sub encode_json { Encode::encode 'UTF-8', _encode_value(shift) }
|
|
|
|
sub false () {$FALSE} ## no critic (prototypes)
|
|
|
|
sub from_json {
|
|
my $err = _decode(\my $value, shift, 1);
|
|
return defined $err ? croak $err : $value;
|
|
}
|
|
|
|
sub j {
|
|
return encode_json $_[0] if ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH';
|
|
return decode_json $_[0];
|
|
}
|
|
|
|
sub to_json { _encode_value(shift) }
|
|
|
|
sub true () {$TRUE} ## no critic (prototypes)
|
|
|
|
sub _decode {
|
|
my $valueref = shift;
|
|
|
|
eval {
|
|
|
|
# Missing input
|
|
die "Missing or empty input\n" unless length( local $_ = shift );
|
|
|
|
# UTF-8
|
|
$_ = eval { Encode::decode('UTF-8', $_, 1) } unless shift;
|
|
die "Input is not UTF-8 encoded\n" unless defined $_;
|
|
|
|
# Value
|
|
$$valueref = _decode_value();
|
|
|
|
# Leftover data
|
|
return m/\G[\x20\x09\x0a\x0d]*\z/gc || _throw('Unexpected data');
|
|
} ? return undef : chomp $@;
|
|
|
|
return $@;
|
|
}
|
|
|
|
sub _decode_array {
|
|
my @array;
|
|
until (m/\G[\x20\x09\x0a\x0d]*\]/gc) {
|
|
|
|
# Value
|
|
push @array, _decode_value();
|
|
|
|
# Separator
|
|
redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
|
|
|
|
# End
|
|
last if m/\G[\x20\x09\x0a\x0d]*\]/gc;
|
|
|
|
# Invalid character
|
|
_throw('Expected comma or right square bracket while parsing array');
|
|
}
|
|
|
|
return \@array;
|
|
}
|
|
|
|
sub _decode_object {
|
|
my %hash;
|
|
until (m/\G[\x20\x09\x0a\x0d]*\}/gc) {
|
|
|
|
# Quote
|
|
m/\G[\x20\x09\x0a\x0d]*"/gc
|
|
or _throw('Expected string while parsing object');
|
|
|
|
# Key
|
|
my $key = _decode_string();
|
|
|
|
# Colon
|
|
m/\G[\x20\x09\x0a\x0d]*:/gc
|
|
or _throw('Expected colon while parsing object');
|
|
|
|
# Value
|
|
$hash{$key} = _decode_value();
|
|
|
|
# Separator
|
|
redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
|
|
|
|
# End
|
|
last if m/\G[\x20\x09\x0a\x0d]*\}/gc;
|
|
|
|
# Invalid character
|
|
_throw('Expected comma or right curly bracket while parsing object');
|
|
}
|
|
|
|
return \%hash;
|
|
}
|
|
|
|
sub _decode_string {
|
|
my $pos = pos;
|
|
|
|
# Extract string with escaped characters
|
|
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
|
|
my $str = $1;
|
|
|
|
# Invalid character
|
|
unless (m/\G"/gc) {
|
|
_throw('Unexpected character or invalid escape while parsing string')
|
|
if m/\G[\x00-\x1f\\]/;
|
|
_throw('Unterminated string');
|
|
}
|
|
|
|
# Unescape popular characters
|
|
if (index($str, '\\u') < 0) {
|
|
$str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
|
|
return $str;
|
|
}
|
|
|
|
# Unescape everything else
|
|
my $buffer = '';
|
|
while ($str =~ m/\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
|
|
$buffer .= $1;
|
|
|
|
# Popular character
|
|
if ($2) { $buffer .= $ESCAPE{$2} }
|
|
|
|
# Escaped
|
|
else {
|
|
my $ord = hex $3;
|
|
|
|
# Surrogate pair
|
|
if (($ord & 0xf800) == 0xd800) {
|
|
|
|
# High surrogate
|
|
($ord & 0xfc00) == 0xd800
|
|
or pos($_) = $pos + pos($str), _throw('Missing high-surrogate');
|
|
|
|
# Low surrogate
|
|
$str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
|
|
or pos($_) = $pos + pos($str), _throw('Missing low-surrogate');
|
|
|
|
$ord = 0x10000 + ($ord - 0xd800) * 0x400 + (hex($1) - 0xdc00);
|
|
}
|
|
|
|
# Character
|
|
$buffer .= pack 'U', $ord;
|
|
}
|
|
}
|
|
|
|
# The rest
|
|
return $buffer . substr $str, pos $str, length $str;
|
|
}
|
|
|
|
sub _decode_value {
|
|
|
|
# Leading whitespace
|
|
m/\G[\x20\x09\x0a\x0d]*/gc;
|
|
|
|
# String
|
|
return _decode_string() if m/\G"/gc;
|
|
|
|
# Object
|
|
return _decode_object() if m/\G\{/gc;
|
|
|
|
# Array
|
|
return _decode_array() if m/\G\[/gc;
|
|
|
|
# Number
|
|
my ($i) = /\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
|
|
return 0 + $i if defined $i;
|
|
|
|
# True
|
|
return $TRUE if m/\Gtrue/gc;
|
|
|
|
# False
|
|
return $FALSE if m/\Gfalse/gc;
|
|
|
|
# Null
|
|
return undef if m/\Gnull/gc; ## no critic (return)
|
|
|
|
# Invalid character
|
|
_throw('Expected string, array, object, number, boolean or null');
|
|
}
|
|
|
|
sub _encode_array {
|
|
'[' . join(',', map { _encode_value($_) } @{$_[0]}) . ']';
|
|
}
|
|
|
|
sub _encode_object {
|
|
my $object = shift;
|
|
my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) }
|
|
sort keys %$object;
|
|
return '{' . join(',', @pairs) . '}';
|
|
}
|
|
|
|
sub _encode_string {
|
|
my $str = shift;
|
|
$str =~ s!([\x00-\x1f\x{2028}\x{2029}\\"/])!$REVERSE{$1}!gs;
|
|
return "\"$str\"";
|
|
}
|
|
|
|
sub _encode_value {
|
|
my $value = shift;
|
|
|
|
# Reference
|
|
if (my $ref = ref $value) {
|
|
|
|
# Object
|
|
return _encode_object($value) if $ref eq 'HASH';
|
|
|
|
# Array
|
|
return _encode_array($value) if $ref eq 'ARRAY';
|
|
|
|
# True or false
|
|
return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
|
|
return $value ? 'true' : 'false' if $ref eq 'JSON::Tiny::_Bool';
|
|
|
|
# Blessed reference with TO_JSON method
|
|
if (blessed $value && (my $sub = $value->can('TO_JSON'))) {
|
|
return _encode_value($value->$sub);
|
|
}
|
|
}
|
|
|
|
# Null
|
|
return 'null' unless defined $value;
|
|
|
|
|
|
# Number (bitwise operators change behavior based on the internal value type)
|
|
|
|
return $value
|
|
if B::svref_2object(\$value)->FLAGS & (B::SVp_IOK | B::SVp_NOK)
|
|
# filter out "upgraded" strings whose numeric form doesn't strictly match
|
|
&& 0 + $value eq $value
|
|
# filter out inf and nan
|
|
&& $value * 0 == 0;
|
|
|
|
# String
|
|
return _encode_string($value);
|
|
}
|
|
|
|
sub _throw {
|
|
|
|
# Leading whitespace
|
|
m/\G[\x20\x09\x0a\x0d]*/gc;
|
|
|
|
# Context
|
|
my $context = 'Malformed JSON: ' . shift;
|
|
if (m/\G\z/gc) { $context .= ' before end of data' }
|
|
else {
|
|
my @lines = split "\n", substr($_, 0, pos);
|
|
$context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
|
|
}
|
|
|
|
die "$context\n";
|
|
}
|
|
|
|
# Emulate boolean type
|
|
package JSON::Tiny::_Bool;
|
|
use overload '""' => sub { ${$_[0]} }, fallback => 1;
|
|
1;
|