view release on metacpan or  search on metacpan

lib/JSON/Tiny/Subclassable.pm  view on Meta::CPAN

			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;
	}