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;