package Tail; use strict; use warnings; use Getopt::Long; use Pod::Usage; use Scalar::Util qw{blessed}; sub _Error { my $parser = shift; my $yydata = $parser->YYData; exists $yydata->{ERRMSG} and do { warn $yydata->{ERRMSG}; delete $yydata->{ERRMSG}; return; }; my($token)=$parser->YYCurval; my($what)= $token->[0] ? "input: '$token->[0]'" : "end of input"; my @expected = $parser->YYExpect(); my $next = substr($parser->{input}, pos($parser->{input}), 5); local $" = ', '; warn << "ERRMSG"; Syntax error near $what (lin num $token->[1]). Incoming text: === $next === Expected one of these terminals: @expected ERRMSG } { # closure my $lineno = 1; my %lexemename; sub set_lexemename { my $self = shift; my %names = @_; my @keys = keys(%names); @lexemename{@keys} = values(%names); return @lexemename{@keys}; } sub lexer { my $parser = shift; my $beginline = $lineno; for ($parser->{input}) { # contextualize m{\G[ \t\n]*(\#.*)?}gc; m{\G([0-9]+(?:\.[0-9]+)?)}gc and return ('NUM', [$1, $beginline]); m{\G([A-Za-z][A-Za-z0-9_]*)}gc and return ('VAR', [$1, $beginline]); m{\G(.)}gc and do { my $token = exists $lexemename{$1}? $lexemename{$1} : $1; return ($token, [$token, $beginline]); }; return('',undef); } } } # closure sub Run { my($self)=shift; my $yydebug = shift || 0; return $self->YYParse( yylex => \&lexer, yyerror => \&_Error, yydebug => $yydebug, # 0x1F ); } sub uploadfile { my $file = shift; my $msg = shift; my $input = ''; eval { $input = Parse::Eyapp::Base::slurp_file($file) }; if ($@) { print $msg; local $/ = undef; $input = ; } return $input; } sub main { my $package = shift; my $prompt = shift || "Expressions. Press CTRL-D (Unix) or CTRL-Z (Windows) to finish:\n"; my $debug = 0; my $file = ''; my $showtree = 0; my $help; my $result = GetOptions ( "debug!" => \$debug, "file=s" => \$file, "tree!" => \$showtree, "help" => \$help, ); pod2usage() if $help; $debug = 0x1F if $debug; $file = shift if !$file && @ARGV; my $parser = $package->new(); $parser->{input} = uploadfile($file, $prompt); my $tree = $parser->Run( $debug ); print $tree->str()."\n" if $showtree && blessed($tree) && $tree->isa('Parse::Eyapp::Node'); } sub semantic_error { my ($parser, $msg) = @_; $parser->YYData->{ERRMSG} = $msg; $parser->YYError; } 1;