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

use 5.008;
use strict;
use warnings;

{
	package JSON::Tiny::Subclassable;

	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.004';
	our @ISA       = qw(JSON::Tiny);

	use B;
	use Encode ();
	use Scalar::Util ();

	BEGIN {
		eval { require Sub::Name; Sub::Name->import('subname'); 1 }
			or eval q{ sub subname { $_[1] } };
	};

	sub new {
		my $class = shift;
		bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, $class;
	}

	sub error {
		$_[0]->{error} = $_[1] if @_ > 1;
		return $_[0]->{error};
	}

	sub pretty {
		$_[0]->{pretty} = $_[1] if @_ > 1;
		return $_[0]->{pretty};
	}

	sub import {
		my $class  = shift;
		my $caller = caller;
		my $opts   = {};
		while (@_) {
			my $arg = shift;
			$opts->{$arg} = ref $_[0] ? shift @_ : undef;
		}
		if (exists $opts->{'j'}) {
			my $func = ((ref $opts->{j} eq 'HASH') && $opts->{j}{-as}) || 'j';
			no strict 'refs';
			*{"$caller\::$func"} = subname "$class\::j" => sub {
				my $d = shift;
				return $class->new->encode($d) if ref $d eq 'ARRAY' || ref $d eq 'HASH';
				return $class->new->decode($d);
			};
			delete $opts->{'j'};
		}
	}

	__PACKAGE__->import('j');

	# Literal names
	my $FALSE = bless \(my $false = 0), 'JSON::Tiny::_Bool';
	my $TRUE  = bless \(my $true  = 1), 'JSON::Tiny::_Bool';

	# Escaped special character map (with u2028 and u2029)
	my %ESCAPE = (
		'"'     => '"',
		'\\'    => '\\',
		'/'     => '/',
		'b'     => "\x07",
		'f'     => "\x0C",
		'n'     => "\x0A",
		'r'     => "\x0D",
		't'     => "\x09",
		'u2028' => "\x{2028}",
		'u2029' => "\x{2029}"
	);
	my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
	for (0x00 .. 0x1F, 0x7F) {
		my $k = pack 'C', $_;
		$REVERSE{$k} = sprintf '\u%.4X', $_ unless defined $REVERSE{$k};
	}

	# Unicode encoding detection
	my $UTF_PATTERNS = {
		'UTF-32BE' => qr/^\0\0\0[^\0]/,
		'UTF-16BE' => qr/^\0[^\0]\0[^\0]/,
		'UTF-32LE' => qr/^[^\0]\0\0\0/,
		'UTF-16LE' => qr/^[^\0]\0[^\0]\0/
	};

	my $WHITESPACE_RE = qr/[\x20\x09\x0a\x0d]*/;

	sub DOES {
		my ($proto, $role) = @_;
		return 1 if $role eq 'Mojo::JSON';
		return $proto->SUPER::DOES($role);
	}

	sub decode {
		my ($self, $bytes) = @_;

		# Cleanup
		$self->error(undef);

		# Missing input
		$self->error('Missing or empty input') and return undef unless $bytes; ## no critic (undef)

		# Remove BOM
		$bytes =~ s/^(?:\357\273\277|\377\376\0\0|\0\0\376\377|\376\377|\377\376)//g;

		# Wide characters
		$self->error('Wide character in input') and return undef ## no critic (undef)
			unless utf8::downgrade($bytes, 1);

		# Detect and decode Unicode
		my $encoding = 'UTF-8';
		$bytes =~ $UTF_PATTERNS->{$_} and $encoding = $_ for keys %$UTF_PATTERNS;

		my $d_res = eval { $bytes = Encode::decode($encoding, $bytes, 1); 1 };
		$bytes = undef unless $d_res;

		# Object or array
		my $res = eval {
			local $_ = $bytes;

			# Leading whitespace
			m/\G$WHITESPACE_RE/gc;

			# Array
			my $ref;
			if (m/\G\[/gc) { $ref = $self->_decode_array() }

			# Object
			elsif (m/\G\{/gc) { $ref = $self->_decode_object() }

			# Unexpected
			else { $self->_exception('Expected array or object') }

			# Leftover data
			unless (m/\G$WHITESPACE_RE\z/gc) {
				my $got = ref $ref eq 'ARRAY' ? 'array' : 'object';
				$self->_exception("Unexpected data after $got");
			}

			$ref;
		};

		# Exception
		if (!$res && (my $e = $@)) {
			chomp $e;
			$self->error($e);
		}

		return $res;
	}

	sub encode {
		my ($self, $ref) = @_;

		my $eof = '';
		if ($self->pretty) {
			$self->{_indent} = '';
			$eof .= "\n";
		}

		return Encode::encode 'UTF-8', $self->_encode_values($ref).$eof;
	}

	sub false {$FALSE}
	sub true  {$TRUE}

	sub _new_hash  { +{} }
	sub _new_array { +[] }

	sub _decode_array {
		my $self  = shift;
		my $array = $self->_new_array;
		until (m/\G$WHITESPACE_RE\]/gc) {

			# Value
			push @$array, $self->_decode_value();

			# Separator
			redo if m/\G$WHITESPACE_RE,/gc;

			# End
			last if m/\G$WHITESPACE_RE\]/gc;

			# Invalid character
			$self->_exception('Expected comma or right square bracket while parsing array');
		}

		return $array;
	}

	sub _decode_object {
		my $self = shift;
		my $hash = $self->_new_hash;
		until (m/\G$WHITESPACE_RE\}/gc) {

			# Quote
			m/\G$WHITESPACE_RE"/gc
				or $self->_exception('Expected string while parsing object');

			# Key
			my $key = $self->_decode_string();

			# Colon
			m/\G$WHITESPACE_RE:/gc
				or $self->_exception('Expected colon while parsing object');

			# Value
			$hash->{$key} = $self->_decode_value();

			# Separator
			redo if m/\G$WHITESPACE_RE,/gc;

			# End
			last if m/\G$WHITESPACE_RE\}/gc;

			# Invalid character
			$self->_exception('Expected comma or right curly bracket while parsing object');
		}

		return $hash;
	}

	sub _decode_string {
		my $self = shift;
		my $pos = pos;

		# Extract string with escaped characters
		m#\G(((?:[^\x00-\x1F\\"]|\\(?:["\\/bfnrt]|u[[:xdigit:]]{4})){0,32766})*)#gc;
		my $str = $1;

		# Missing quote
		unless (m/\G"/gc) {
			$self->_exception('Unexpected character or invalid escape while parsing string')
				if m/\G[\x00-\x1F\\]/;
			$self->_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), $self->_exception('Missing high-surrogate');

					# Low surrogate
					$str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
						or pos($_) = $pos + pos($str), $self->_exception('Missing low-surrogate');

					# Pair
					$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 {
		my $self = shift;

		# Leading whitespace
		m/\G$WHITESPACE_RE/gc;

		# String
		return $self->_decode_string() if m/\G"/gc;

		# Array
		return $self->_decode_array() if m/\G\[/gc;

		# Object
		return $self->_decode_object() if m/\G\{/gc;

		# Number
		return 0 + $1
			if m/\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;

		# True
		return $self->true if m/\Gtrue/gc;

		# False
		return $self->false if m/\Gfalse/gc;

		# Null
		return undef if m/\Gnull/gc;  ## no critic (return)

		# Invalid data
		$self->_exception('Expected string, array, object, number, boolean or null');
	}

	sub _encode_array {
		my $self = shift;

		return "[]" unless @{$_[0]};

		return '[' . join(',', map { $self->_encode_values($_) } @{shift()}) . ']'
			unless exists $self->{_indent};

		my $indent = $self->{_indent};
		return "\[\n$indent\t"
			. join(",\n$indent\t", map {
				local $self->{_indent} = "$indent\t"; $self->_encode_values($_)
			} @{shift()})
			. "\n$indent\]";
	}

	sub _encode_object {
		my $self = shift;
		my $object = shift;

		my $indent;
		if (exists $self->{_indent}) {
			$indent = $self->{_indent};
			$self->{_indent} .= "\t";
		}

		# Encode pairs
		my @pairs;
		my $space = defined $indent ? q( ) : q();
		while (my ($k, $v) = each %$object) {
			push @pairs, sprintf(
				'%s:%s%s',
				$self->_encode_string($k),
				$space,
				$self->_encode_values($v),
			);
		}

		if (defined $indent)
		{
			$self->{_indent} =~ s/^.//;
			return "{}" unless @pairs;
			return "\{\n$indent\t" . join(",\n$indent\t", @pairs) . "\n$indent\}";
		}
		else
		{
			return '{' . join(',', @pairs) . '}';
		}
	}

	sub _encode_string {
		my $self = shift;
		my $string = shift;

		# Escape string
		$string =~ s!([\x00-\x1F\x7F\x{2028}\x{2029}\\"/\b\f\n\r\t])!$REVERSE{$1}!gs;

		# Stringify
		return "\"$string\"";
	}

	sub _encode_values {
		my $self = shift;
		my $value = shift;

		# Reference
		if (my $ref = ref $value) {

			# Array
			return $self->_encode_array($value) if $ref eq 'ARRAY';

			# Object
			return $self->_encode_object($value) if $ref eq 'HASH';

			# 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 $self->_encode_values($value->$sub);
			}
		}

		# Null
		return 'null' unless defined $value;

		# Number
		return 0 + $value
			if B::svref_2object(\$value)->FLAGS & (B::SVp_IOK | B::SVp_NOK);

		# String
		return $self->_encode_string($value);
	}

	sub _exception {
		my $self = shift;

		# 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 || '');
		}

		# Throw
		die "$context\n";
	}
}

{
	package JSON::Tiny::_Bool;
	no warnings;
	use overload
		'0+' => sub { ${$_[0]} },
		'""' => sub { ${$_[0]} },
		fallback => 1,
	;
	sub DOES {
		my ($proto, $role) = @_;
		return 1 if $role eq 'Mojo::JSON::_Bool';
		return 1 if $role =~ /^JSON::(?:PP::|XS::)?Boolean$/;
		return $proto->SUPER::DOES($role);
	}
}

1;

__END__