libjson-tiny-perl/lib/JSON/Tiny.pm
2018-03-27 21:25:33 +02:00

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;