view release on metacpan or  search on metacpan

lib/Data/SExpression/Parser.pm  view on Meta::CPAN

sub
#line 34 "lib/Data/SExpression/Parser.yp"
{ $_[0]->handler->new_cons($_[1], undef) }
	],
	[#Rule 11
		 'list_interior', 0,
sub
#line 35 "lib/Data/SExpression/Parser.yp"
{ undef }
	],
	[#Rule 12
		 'quoted', 2,
sub
#line 40 "lib/Data/SExpression/Parser.yp"
{ $_[0]->handler->new_cons($_[0]->handler->new_symbol($_[1]),
                                                                    $_[0]->handler->new_cons($_[2], undef))}
	]
],
                                  @_);
    bless($self,$class);
}

#line 44 "lib/Data/SExpression/Parser.yp"


sub set_input {
    my $self = shift;
    my $input = shift;
    die(__PACKAGE__ . "::set_input called with 0 arguments") unless defined($input);
    $self->YYData->{INPUT} = $input;
}

sub set_handler {
    my $self = shift;
    my $handler = shift or die(__PACKAGE__ . "::set_handler called with 0 arguments");
    $self->YYData->{HANDLER} = $handler;
    weaken $self->YYData->{HANDLER};
}

sub handler {
    my $self = shift;
    return $self->YYData->{HANDLER};
}

sub unparsed_input {
    my $self = shift;
    return substr($self->YYData->{INPUT}, pos($self->YYData->{INPUT}));
}


my %quotes = (q{'} => 'quote',
              q{`} => 'quasiquote',
              q{,} => 'unquote');


sub lexer {
    my $self = shift;

    defined($self->YYData->{INPUT}) or return ('', undef);

    my $symbol_char = qr{[*!\$[:alpha:]\?<>=/+:_{}-]};

    for($self->YYData->{INPUT}) {
        $_ =~ /\G \s* (?: ; .* \s* )* /gcx;

        /\G ([+-]? \d+ (?:[.]\d*)?) /gcx
        || /\G ([+-]? [.] \d+) /gcx
          and return ('NUMBER', $1);

        /\G ($symbol_char ($symbol_char | \d | [.] )*)/gcx
          and return ('SYMBOL', $1);

        /\G (\| [^|]* \|) /gcx
          and return ('SYMBOL', $1);

        /\G " ([^"\\]* (?: \\. [^"\\]*)*) "/gcx
          and return ('STRING', defined($1) ? $1 : "");

        /\G ([().])/gcx
          and return ($1, $1);

        /\G ([`',]) /gcx
          and return ('QUOTE', $quotes{$1});

        return ('', undef);
    }
}

sub error {
    my $self = shift;
    my ($tok, $val) = $self->YYLexer->($self);
    die("Parse error near: '" . $self->unparsed_input . "'");
    return undef;
}

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

1;