json_parser.yp

%{
use strict;
use warnings;
%}
%%
JSON       : value
           ;
value      : atom
           | number
           | string
           | '[' array             { return $_[2] }
           | '{' object            { return $_[2] }
           ;
array      : ']'                   { return [] }
           | ',' ']'               { return [] }
           | element array_cdr     { unshift @{$_[2]}, $_[1];return $_[2] }
           ;
array_cdr  : ']'                   { return [] }
           | ',' ']'               { return [] }
           | ',' element array_cdr { unshift @{$_[3]}, $_[2];return $_[3] }
           ;
element    : value
           ;
object     : '}'                   { return {} }
           | ',' '}'               { return {} }
           | member object_cdr     { return { %{ $_[2] }, %{ $_[1] } } }
           ;
object_cdr : '}'                   { return {} }
           | ',' '}'               { return {} }
           | ',' member object_cdr { return { %{ $_[3] }, %{ $_[2] } } }
           ;
member     : key ':' value         { return { $_[1] => $_[3] } }
           ;
key        : string
           | identifier
           ;
%%
sub yyerror {}

sub yylex {
    my ( $self ) = @_;
    my $number = qr/-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][+-]\d+)?/;
    my $double_quoted_string = qr/
            ^"([^\x00-\x1f\"\\]*
            (?:\\(?:[\"\\\/bfnrt]|u[0-9a-fA-F]{4})
            [^\x00-\x1f\"\\]*)*)"
        /xms;
    my $single_quoted_string = qr/
            ^'([^\x00-\x1f\'\\]*
            (?:\\(?:[\'\\\/bfnrt]|u[0-9a-fA-F]{4})
            [^\x00-\x1f\'\\]*)*)'
        /xms;

    for ( $self->YYData->{INPUT} ) {
        s|\s+||;
        s|^($number)||                and return ('number', $1);
        s/^(true|false|null)//        and return ('atom', $1);
        s|^([_a-zA-Z][_a-zA-Z0-9]*)|| and return ('identifier', $1);
        s|$double_quoted_string||     and return ('string', $1);
        s|$single_quoted_string||     and return ('string', $1);
        s|^(.)||                      and return ($1, $1);
    }
    return ('', undef);
}

sub run {
    my $self = shift;
    return $self->YYParse( yylex => \&yylex, yyerror => \&yyerror );
}