JSONバリデータ

3時間30分ぐらいでした。大急ぎで書いたのでエラーメッセージがアレです。
(実際は小一時間バグに悩まされてました。)

package Local::Validator;
use strict;
use warnings;
use utf8;

my $digit   = qr/[\x30-\x39]/;
my $hexdig4 = qr/[\x30-\x39\x41-\x46\x61-\x66]{4}/;

my $ws = qr/[\x20\x09\x0a\x0d]*/;
my $begin_array     = qr/$ws\x5b$ws/;
my $begin_object    = qr/$ws\x7b$ws/;
my $end_array       = qr/$ws\x5d$ws/;
my $end_object      = qr/$ws\x7d$ws/;
my $name_separator  = qr/$ws\x3a$ws/;
my $value_separator = qr/$ws\x2c$ws/;

my $false = qr/false/;
my $null  = qr/null/;
my $true  = qr/true/;

my $decimal_point = qr/\x2E/;
my $digit1_9      = qr/[\x31-\x39]/;
my $e             = qr/[\x65\x45]/;
my $minus         = qr/\x2d/;
my $plus          = qr/\x2b/;
my $zero          = qr/\x30/;
my $exp           = qr/$e(?:$minus|$plus)?$digit+/;
my $frac          = qr/$decimal_point$digit+/;
my $int           = qr/(?:$zero|$digit1_9$digit*)/;
my $number        = qr/$minus?$int$frac?$exp?/;

my $quotation_mark = qr/\x22/;
my $escape         = qr/\x5C/;
my $unescaped      = qr/[\x20-\x21\x23-\x5b\x5d-\x{10ffff}]/;
my $escaped        = qr/$escape([\x22\x5c\x2f\x62\x66\x6e\x72\x74]|\x75$hexdig4)/;
my $char           = qr/(?:$unescaped|$escaped)/;
my $string         = qr/$quotation_mark$char*$quotation_mark/;

my $end = qr/$/;

my @token = (
	[ begin_array     => $begin_array ],
	[ begin_object    => $begin_object ],
	[ end_array       => $end_array ],
	[ end_object      => $end_object ],
	[ name_separator  => $name_separator ],
	[ value_separator => $value_separator ],
	[ false           => $false ],
	[ null            => $null ],
	[ true            => $true ],
	[ number          => $number ],
	[ string          => $string ],
	[ end             => $end ],
);

sub new {
	my ($class, $string) = @_;

	my $self = bless {
		string => $string,
		symbol => undef,
		value  => undef,
		pos    => 0,
		error  => '',
	}, ref($class) || $class;

	return $self;
}

sub error { $_[0]->{error} }

sub _get_symbol {
	my ($self, $item) = @_;

	$self->{pos} = pos($self->{string});

	foreach my $t (@token){
		my ($name, $matcher) = @{$t};
		$self->{string} =~ /\G($matcher)/gc or next;

		$self->{value}  = $1;
		$self->{symbol} = $name;
		return $name;
	}

	die("symbol: illegal symbol pos $self->{pos} \n");
}

sub _accept {
	my ($self, $item) = @_;

	if ($self->{symbol} eq $item){
		$self->_get_symbol;
		return 1;
	}
	return;
}

sub _expect {
	my ($self, $item) = @_;

	$self->_accept($item) or
		die("expect: unexpected symbol pos $self->{pos} : want " .
			"$item, but $self->{symbol}\n");

	return 1;
}

sub _accept_object {
	my ($self) = @_;

	$self->_accept('begin_object') or return;

	do{
		$self->_expect('string');
		$self->_expect('name_separator');
		$self->_expect_value;
	}while($self->_accept('value_separator'));
	$self->_expect('end_object');

	return 1;
}

sub _accept_array {
	my ($self) = @_;

	$self->_accept('begin_array') or return;

	do{
		$self->_expect_value;
	}while($self->_accept('value_separator'));
	$self->_expect('end_array');

	return 1;
}

sub _expect_value {
	my ($self) = @_;

	$self->_accept('false')       and return;
	$self->_accept('null')        and return;
	$self->_accept('true')        and return;
	$self->_accept_object         and return;
	$self->_accept_array          and return;
	$self->_accept('number')      and return;
	$self->_accept('string')      and return;

	die("value: unexpected symbol pos $self->{pos} : $self->{value}\n");
}

sub _json_text {
	my ($self) = @_;

	$self->_accept_object and return;
	$self->_accept_array  and return;

	die("json text: illegal syntax symbol pos $self->{pos} : $self->{value}\n");
}

sub check {
	my ($self) = @_;

	eval{
		$self->_get_symbol;
		$self->_json_text;
		($self->{symbol} eq 'end') or die("check: JSON string over text\n");
	};
	if ($@){
		chomp($self->{error} = $@);
		return;
	}

	return 1;
}

1;