package JSON::Tiny;
# Minimalistic JSON. Adapted from Mojo::JSON and Mojo::Util.
# (c) 2012-2014 David Oswald
# License: Artistic 2.0 license.
# http://www.perlfoundation.org/artistic_license_2_0.
use strict;
use warnings;
use B;
use Carp qw(croak carp);
use Exporter 'import';
use Scalar::Util ();
use Encode ();
our $VERSION = '0.45';
our @EXPORT_OK = qw(decode_json encode_json j);
# Constructor and accessor: we don't have Mojo::Base.
sub new {
my $class = shift;
bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, $class;
}
sub error {
$_[0]->{error} = $_[1] if @_ > 1;
return $_[0]->{error};
}
# Literal names
# Users may override the Booleans with literal 0 or 1 if desired.
our $FALSE = bless \(my $false = 0), 'JSON::Tiny::_Bool';
our $TRUE = bless \(my $true = 1), 'JSON::Tiny::_Bool';
# 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', $_
if ! defined( $REVERSE{$packed} );
}
my $WHITESPACE_RE = qr/[\x20\x09\x0a\x0d]*/;
sub decode {
my $self = shift;
$self->error(undef);
my $value;
return $value if eval{ $value = _decode(shift); 1; };
$self->error(_chomp($@));
return undef; ## no critic(return)
}
sub decode_json {
my $value;
return eval { $value = _decode(shift); 1; } ? $value : croak _chomp($@);
}
sub encode { encode_json($_[1]) }
sub encode_json { Encode::encode 'UTF-8', _encode_value(shift); }
sub false {$FALSE}
sub j {
return encode_json($_[0]) if ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH';
return decode_json($_[0]);
}
sub true {$TRUE}
sub _chomp { chomp $_[0] ? $_[0] : $_[0]; }
sub _decode {
# Missing input
die "Missing or empty input\n" unless length(my $bytes = shift);
# Wide characters
die "Wide character in input\n" unless utf8::downgrade($bytes, 1);
# UTF-8
local $_;
die "Input is not UTF-8 encoded\n"
unless eval { $_ = Encode::decode('UTF-8', $bytes, 1); 1; };
# Value
my $value = _decode_value();
# Leftover data
_exception('Unexpected data') unless m/\G$WHITESPACE_RE\z/gc;
return $value;
}
sub _decode_array {
my @array;
until (m/\G$WHITESPACE_RE\]/gc) {
# Value
push @array, _decode_value();
# Separator
redo if m/\G$WHITESPACE_RE,/gc;
# End
last if m/\G$WHITESPACE_RE\]/gc;
# Invalid character
_exception('Expected comma or right square bracket while parsing array');
}
return \@array;
}
sub _decode_object {
my %hash;
until (m/\G$WHITESPACE_RE\}/gc) {
# Quote
m/\G$WHITESPACE_RE"/gc
or _exception('Expected string while parsing object');
# Key
my $key = _decode_string();
# Colon
m/\G$WHITESPACE_RE:/gc
or _exception('Expected colon while parsing object');
# Value
$hash{$key} = _decode_value();
# Separator
redo if m/\G$WHITESPACE_RE,/gc;
# End
last if m/\G$WHITESPACE_RE\}/gc;
# Invalid character
_exception('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 #83
my $str = $1;
# Invalid character
unless (m/\G"/gc) {
_exception('Unexpected character or invalid escape while parsing string')
if m/\G[\x00-\x1f\\]/;
_exception('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), _exception('Missing high-surrogate');
# Low surrogate
$str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
or pos($_) = $pos + pos($str), _exception('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$WHITESPACE_RE/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
return 0 + $1
if m/\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
# 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
_exception('Expected string, array, object, number, boolean or null');
}
sub _encode_array {
my $array = shift;
return '[' . join(',', map { _encode_value($_) } @$array) . ']';
}
sub _encode_object {
my $object = shift;
my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) }
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 (Scalar::Util::blessed $value && (my $sub = $value->can('TO_JSON'))) {
return _encode_value($value->$sub);
}
}
# Null
return 'null' unless defined $value;
# Number
my $flags = B::svref_2object(\$value)->FLAGS;
return 0 + $value if $flags & (B::SVp_IOK | B::SVp_NOK) && $value * 0 == 0;
# String
return _encode_string($value);
}
sub _exception {
# Leading whitespace
m/\G$WHITESPACE_RE/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 '0+' => sub { ${$_[0]} }, '""' => sub { ${$_[0]} }, fallback => 1;
1;