lib/JSON/Tiny/Subclassable.pm

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__

=head1 NAME

JSON::Tiny::Subclassable

=head1 DESCRIPTION

Although technically this is a subclass of L<JSON::Tiny>, in practice
it's a fork because it overrides every method, and never calls the
supermethods. In fact, even though this is a subclass of L<JSON::Tiny>,
you don't need to have the latter installed to use this module.

The main difference between this module and its parent is that all the
internal calls to private functions have been replaces with calls to
private methods. This makes it easy to override particular parts of the
JSON parsing/generation algorithm.

The other tiny added feature is to support pretty indented output.

This module was written was to make developing L<JSON::MultiValueOrdered>
simpler, but it may be of some use for other purposes as well.

JSON::Tiny::Subclassable is a subclass of L<JSON::Tiny>, which is itself a
fork of L<Mojo::JSON>. Except where noted, the methods listed below behave
identically to the methods of the same names in the superclass.

=head2 Constructor

=over

=item C<< new(%attributes) >>

=back

=head2 Attributes

=over

=item C<< pretty >>

If set to true, indents generated JSON in a pretty fashion.

=item C<< error >>

=back

=head2 Methods

=over

=item C<< decode($bytes) >>

=item C<< encode($ref) >>

=item C<< false >>

=item C<< true >>

=item C<< DOES($role) >>

As per L<UNIVERSAL>::C<DOES>. Returns true for L<Mojo::DOM>.

=back

=head2 Functions

=over

=item C<< j(\@array) >> / C<< j(\%hash) >> / C<< j($bytes) >>

Encode or decode JSON as applicable.

This function may be exported, but is not exported by default. You may
request to import it with a different name:

   use JSON::Tiny::Subclassable j => { -as => 'quick_json' };

=back

=head1 BUGS

Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=JSON-MultiValueOrdered>.

=head1 SEE ALSO

L<JSON::Tiny>,
L<Mojo::JSON>.

=head1 AUTHORS

David J. Oswald.

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2012-2013 by Toby Inkster.

Portions copyright 2012-2013 David J. Oswald.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)