Alt-Acme-Math-XS-CPP
view release on metacpan or search on metacpan
inc/Parse/RecDescent.pm view on Meta::CPAN
last;
}
s/Parse::RecDescent/$runtime_package/gs;
print OUT $_;
}
}
close IN;
print OUT "}\n";
}
$self = Parse::RecDescent->new($grammar, # $grammar
1, # $compiling
$class # $namespace
)
|| croak("Can't compile bad grammar")
if $grammar;
# Do not allow &DESTROY to remove the precompiled namespace
delete $self->{_not_precompiled};
foreach ( keys %{$self->{rules}} ) {
$self->{rules}{$_}{changed} = 1;
}
print OUT "package $class;\n";
if (not $opt{-standalone}) {
print OUT "use Parse::RecDescent;\n";
}
print OUT "{ my \$ERRORS;\n\n";
$code = $self->_code();
if ($opt{-standalone}) {
$code =~ s/Parse::RecDescent/$runtime_package/gs;
}
print OUT $code;
print OUT "}\npackage $class; sub new { ";
print OUT "my ";
require Data::Dumper;
$code = Data::Dumper->Dump([$self], [qw(self)]);
if ($opt{-standalone}) {
$code =~ s/Parse::RecDescent/$runtime_package/gs;
}
print OUT $code;
print OUT "}";
close OUT
or croak("Can't write to new module file '$modulefile'");
}
#endif
package Parse::RecDescent::LineCounter;
sub TIESCALAR # ($classname, \$text, $thisparser, $prevflag)
{
bless {
text => $_[1],
parser => $_[2],
prev => $_[3]?1:0,
}, $_[0];
}
sub FETCH
{
my $parser = $_[0]->{parser};
my $cache = $parser->{linecounter_cache};
my $from = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}
;
unless (exists $cache->{$from})
{
$parser->{lastlinenum} = $parser->{offsetlinenum}
- Parse::RecDescent::_linecount(substr($parser->{fulltext},$from))
+ 1;
$cache->{$from} = $parser->{lastlinenum};
}
return $cache->{$from};
}
sub STORE
{
my $parser = $_[0]->{parser};
$parser->{offsetlinenum} -= $parser->{lastlinenum} - $_[1];
return undef;
}
sub resync # ($linecounter)
{
my $self = tied($_[0]);
die "Tried to alter something other than a LineCounter\n"
unless $self =~ /Parse::RecDescent::LineCounter/;
my $parser = $self->{parser};
my $apparently = $parser->{offsetlinenum}
- Parse::RecDescent::_linecount(${$self->{text}})
+ 1;
$parser->{offsetlinenum} += $parser->{lastlinenum} - $apparently;
return 1;
}
package Parse::RecDescent::ColCounter;
sub TIESCALAR # ($classname, \$text, $thisparser, $prevflag)
{
bless {
text => $_[1],
parser => $_[2],
prev => $_[3]?1:0,
}, $_[0];
}
sub FETCH
{
my $parser = $_[0]->{parser};
my $missing = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}+1;
substr($parser->{fulltext},0,$missing) =~ m/^(.*)\Z/m;
return length($1);
}
sub STORE
{
die "Can't set column number via \$thiscolumn\n";
}
package Parse::RecDescent::OffsetCounter;
sub TIESCALAR # ($classname, \$text, $thisparser, $prev)
{
bless {
text => $_[1],
parser => $_[2],
prev => $_[3]?-1:0,
}, $_[0];
}
sub FETCH
{
my $parser = $_[0]->{parser};
return $parser->{fulltextlen}-length(${$_[0]->{text}})+$_[0]->{prev};
}
sub STORE
{
die "Can't set current offset via \$thisoffset or \$prevoffset\n";
}
package Parse::RecDescent::Rule;
sub new ($$$$$)
{
my $class = ref($_[0]) || $_[0];
my $name = $_[1];
my $owner = $_[2];
my $line = $_[3];
my $replace = $_[4];
if (defined $owner->{"rules"}{$name})
{
my $self = $owner->{"rules"}{$name};
if ($replace && !$self->{"changed"})
{
$self->reset;
}
return $self;
}
else
{
return $owner->{"rules"}{$name} =
bless
{
"name" => $name,
"prods" => [],
"calls" => [],
"changed" => 0,
"line" => $line,
"impcount" => 0,
"opcount" => 0,
"vars" => "",
}, $class;
}
}
sub reset($)
{
@{$_[0]->{"prods"}} = ();
@{$_[0]->{"calls"}} = ();
$_[0]->{"changed"} = 0;
$_[0]->{"impcount"} = 0;
$_[0]->{"opcount"} = 0;
$_[0]->{"vars"} = "";
}
sub DESTROY {}
sub hasleftmost($$)
{
my ($self, $ref) = @_;
my $prod;
foreach $prod ( @{$self->{"prods"}} )
{
return 1 if $prod->hasleftmost($ref);
}
return 0;
}
sub leftmostsubrules($)
{
my $self = shift;
my @subrules = ();
my $prod;
foreach $prod ( @{$self->{"prods"}} )
{
push @subrules, $prod->leftmostsubrule();
}
return @subrules;
}
sub expected($)
{
my $self = shift;
my @expected = ();
my $prod;
foreach $prod ( @{$self->{"prods"}} )
{
inc/Parse/RecDescent.pm view on Meta::CPAN
q{' . $self->{"name"} .'},
$tracelevel)
if defined $::RD_TRACE;
$return = $score_return;
}
splice @{$thisparser->{errors}}, $err_at;
$return = $item[$#item] unless defined $return;
if (defined $::RD_TRACE)
{
Parse::RecDescent::_trace(q{>>'.Parse::RecDescent::_matchtracemessage($self).' rule<< (return value: [} .
$return . q{])}, "",
q{' . $self->{"name"} .'},
$tracelevel);
Parse::RecDescent::_trace(q{(consumed: [} .
Parse::RecDescent::_tracemax(substr($_[1],0,-length($text))) . q{])},
Parse::RecDescent::_tracefirst($text),
, q{' . $self->{"name"} .'},
$tracelevel)
}
$_[1] = $text;
return $return;
}
';
return $code;
}
my @left;
sub isleftrec($$)
{
my ($self, $rules) = @_;
my $root = $self->{"name"};
@left = $self->leftmostsubrules();
my $next;
foreach $next ( @left )
{
next unless defined $rules->{$next}; # SKIP NON-EXISTENT RULES
return 1 if $next eq $root;
my $child;
foreach $child ( $rules->{$next}->leftmostsubrules() )
{
push(@left, $child)
if ! _contains($child, @left) ;
}
}
return 0;
}
package Parse::RecDescent::Production;
sub describe ($;$)
{
return join ' ', map { $_->describe($_[1]) or () } @{$_[0]->{items}};
}
sub new ($$;$$)
{
my ($self, $line, $uncommit, $error) = @_;
my $class = ref($self) || $self;
bless
{
"items" => [],
"uncommit" => $uncommit,
"error" => $error,
"line" => $line,
strcount => 0,
patcount => 0,
dircount => 0,
actcount => 0,
}, $class;
}
sub expected ($)
{
my $itemcount = scalar @{$_[0]->{"items"}};
return ($itemcount) ? $_[0]->{"items"}[0]->describe(1) : '';
}
sub hasleftmost ($$)
{
my ($self, $ref) = @_;
return ${$self->{"items"}}[0] eq $ref if scalar @{$self->{"items"}};
return 0;
}
sub isempty($)
{
my $self = shift;
return 0 == @{$self->{"items"}};
}
sub leftmostsubrule($)
{
my $self = shift;
if ( $#{$self->{"items"}} >= 0 )
{
my $subrule = $self->{"items"}[0]->issubrule();
return $subrule if defined $subrule;
}
return ();
}
sub checkleftmost($)
{
my @items = @{$_[0]->{"items"}};
if (@items==1 && ref($items[0]) =~ /\AParse::RecDescent::Error/
&& $items[0]->{commitonly} )
{
Parse::RecDescent::_warn(2,"Lone <error?> in production treated
as <error?> <reject>");
Parse::RecDescent::_hint("A production consisting of a single
conditional <error?> directive would
normally succeed (with the value zero) if the
rule is not 'commited' when it is
tried. Since you almost certainly wanted
'<error?> <reject>' Parse::RecDescent
supplied it for you.");
push @{$_[0]->{items}},
inc/Parse/RecDescent.pm view on Meta::CPAN
explicit action has the specified
\"auto-action\" automatically
appended.");
}
elsif ($parser->{_AUTOTREE} && defined($item) && !$item->isa("Parse::RecDescent::Action"))
{
if ($i==1 && $item->isterminal)
{
$code .= $parser->{_AUTOTREE}{TERMINAL}->code($namespace,$rule);
}
else
{
$code .= $parser->{_AUTOTREE}{NODE}->code($namespace,$rule);
}
Parse::RecDescent::_warn(1,"Autogenerating tree-building action in rule
\"$rule->{name}\"")
and
Parse::RecDescent::_hint("The directive <autotree> was specified,
so any production not ending
in an explicit action has
some parse-tree building code
automatically appended.");
}
$code .=
'
Parse::RecDescent::_trace(q{>>'.Parse::RecDescent::_matchtracemessage($self).' production: ['
. $self->describe . ']<<},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '},
$tracelevel)
if defined $::RD_TRACE;
' . ( $parser->{_check}{itempos} ? '
if ( defined($_itempos) )
{
Parse::RecDescent::Production::_update_itempos($_itempos, $itempos[ 1], undef, [qw(from)]);
Parse::RecDescent::Production::_update_itempos($_itempos, $itempos[-1], undef, [qw(to)]);
}
' : '' ) . '
$_matched = 1;
last;
}
';
return $code;
}
1;
package Parse::RecDescent::Action;
sub describe { undef }
sub sethashname { $_[0]->{hashname} = '__ACTION' . ++$_[1]->{actcount} .'__'; }
sub new
{
my $class = ref($_[0]) || $_[0];
bless
{
"code" => $_[1],
"lookahead" => $_[2],
"line" => $_[3],
}, $class;
}
sub issubrule { undef }
sub isterminal { 0 }
sub code($$$$)
{
my ($self, $namespace, $rule) = @_;
'
Parse::RecDescent::_trace(q{Trying action},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '},
$tracelevel)
if defined $::RD_TRACE;
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
$_tok = ($_noactions) ? 0 : do ' . $self->{"code"} . ';
' . ($self->{"lookahead"}<0?'if':'unless') . ' (defined $_tok)
{
Parse::RecDescent::_trace(q{<<'.Parse::RecDescent::_matchtracemessage($self,1).' action>> (return value: [undef])})
if defined $::RD_TRACE;
last;
}
Parse::RecDescent::_trace(q{>>'.Parse::RecDescent::_matchtracemessage($self).' action<< (return value: [}
. $_tok . q{])},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
push @item, $_tok;
' . ($self->{line}>=0 ? '$item{'. $self->{hashname} .'}=$_tok;' : '' ) .'
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
'
}
1;
package Parse::RecDescent::Directive;
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; }
sub issubrule { undef }
sub isterminal { 0 }
sub describe { $_[1] ? '' : $_[0]->{name} }
sub new ($$$$$)
{
my $class = ref($_[0]) || $_[0];
bless
{
"code" => $_[1],
"lookahead" => $_[2],
"line" => $_[3],
"name" => $_[4],
}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule) = @_;
'
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
Parse::RecDescent::_trace(q{Trying directive: ['
. $self->describe . ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '},
$tracelevel)
if defined $::RD_TRACE; ' .'
$_tok = do { ' . $self->{"code"} . ' };
if (defined($_tok))
{
Parse::RecDescent::_trace(q{>>'.Parse::RecDescent::_matchtracemessage($self).' directive<< (return value: [}
. $_tok . q{])},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
}
else
{
Parse::RecDescent::_trace(q{<<'.Parse::RecDescent::_matchtracemessage($self,1).' directive>>},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
}
' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
last '
. ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
push @item, $item{'.$self->{hashname}.'}=$_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
'
}
1;
package Parse::RecDescent::UncondReject;
sub issubrule { undef }
sub isterminal { 0 }
sub describe { $_[1] ? '' : $_[0]->{name} }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; }
sub new ($$$;$)
{
my $class = ref($_[0]) || $_[0];
bless
{
"lookahead" => $_[1],
"line" => $_[2],
"name" => $_[3],
}, $class;
}
# MARK, YOU MAY WANT TO OPTIMIZE THIS.
sub code($$$$)
{
my ($self, $namespace, $rule) = @_;
'
Parse::RecDescent::_trace(q{>>Rejecting production<< (found '
. $self->describe . ')},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '},
$tracelevel)
if defined $::RD_TRACE;
undef $return;
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
$_tok = undef;
' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
last '
. ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
'
}
1;
package Parse::RecDescent::Error;
sub issubrule { undef }
sub isterminal { 0 }
sub describe { $_[1] ? '' : $_[0]->{commitonly} ? '<error?:...>' : '<error...>' }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; }
sub new ($$$$$)
{
my $class = ref($_[0]) || $_[0];
bless
{
"msg" => $_[1],
"lookahead" => $_[2],
"commitonly" => $_[3],
"line" => $_[4],
}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule) = @_;
my $action = '';
if ($self->{"msg"}) # ERROR MESSAGE SUPPLIED
{
#WAS: $action .= "Parse::RecDescent::_error(qq{$self->{msg}}" . ',$thisline);';
$action .= 'push @{$thisparser->{errors}}, [qq{'.$self->{msg}.'},$thisline];';
}
else # GENERATE ERROR MESSAGE DURING PARSE
{
$action .= '
my $rule = $item[0];
$rule =~ s/_/ /g;
#WAS: Parse::RecDescent::_error("Invalid $rule: " . $expectation->message() ,$thisline);
push @{$thisparser->{errors}}, ["Invalid $rule: " . $expectation->message() ,$thisline];
';
}
my $dir =
new Parse::RecDescent::Directive('if (' .
($self->{"commitonly"} ? '$commit' : '1') .
") { do {$action} unless ".' $_noactions; undef } else {0}',
$self->{"lookahead"},0,$self->describe);
$dir->{hashname} = $self->{hashname};
return $dir->code($namespace, $rule, 0);
}
1;
package Parse::RecDescent::Token;
sub sethashname { $_[0]->{hashname} = '__PATTERN' . ++$_[1]->{patcount} . '__'; }
sub issubrule { undef }
sub isterminal { 1 }
sub describe ($) { shift->{'description'}}
# ARGS ARE: $self, $pattern, $left_delim, $modifiers, $lookahead, $linenum
sub new ($$$$$$)
{
my $class = ref($_[0]) || $_[0];
my $pattern = $_[1];
my $pat = $_[1];
my $ldel = $_[2];
my $rdel = $ldel;
$rdel =~ tr/{[(</}])>/;
my $mod = $_[3];
my $desc;
if ($ldel eq '/') { $desc = "$ldel$pattern$rdel$mod" }
else { $desc = "m$ldel$pattern$rdel$mod" }
$desc =~ s/\\/\\\\/g;
$desc =~ s/\$$/\\\$/g;
$desc =~ s/}/\\}/g;
$desc =~ s/{/\\{/g;
if (!eval "no strict;
local \$SIG{__WARN__} = sub {0};
'' =~ m$ldel$pattern$rdel$mod" and $@)
{
Parse::RecDescent::_warn(3, "Token pattern \"m$ldel$pattern$rdel$mod\"
may not be a valid regular expression",
$_[5]);
$@ =~ s/ at \(eval.*/./;
Parse::RecDescent::_hint($@);
}
# QUIETLY PREVENT (WELL-INTENTIONED) CALAMITY
$mod =~ s/[gc]//g;
$pattern =~ s/(\A|[^\\])\\G/$1/g;
bless
{
"pattern" => $pattern,
"ldelim" => $ldel,
"rdelim" => $rdel,
"mod" => $mod,
"lookahead" => $_[4],
"line" => $_[5],
"description" => $desc,
}, $class;
}
sub code($$$$$)
{
my ($self, $namespace, $rule, $check) = @_;
my $ldel = $self->{"ldelim"};
my $rdel = $self->{"rdelim"};
my $sdel = $ldel;
my $mod = $self->{"mod"};
$sdel =~ s/[[{(<]/{}/;
my $code = '
Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe
. ']}, Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '},
$tracelevel)
if defined $::RD_TRACE;
undef $lastsep;
$expectation->is(q{' . ($rule->hasleftmost($self) ? ''
: $self->describe ) . '})->at($text);
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . '
' . ($self->{"lookahead"}<0?'if':'unless')
. ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and '
. ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '')
. ' $text =~ m' . $ldel . '\A(?:' . $self->{"pattern"} . ')' . $rdel . $mod . ')
{
'.($self->{"lookahead"} ? '$text = $_savetext;' : '$text = $lastsep . $text if defined $lastsep;') .
($check->{itempos} ? Parse::RecDescent::Production::unincitempos() : '') . '
$expectation->failed();
Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
last;
}
$current_match = substr($text, $-[0], $+[0] - $-[0]);
substr($text,0,length($current_match),q{});
Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
. $current_match . q{])},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
push @item, $item{'.$self->{hashname}.'}=$current_match;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
';
return $code;
}
1;
package Parse::RecDescent::Literal;
sub sethashname { $_[0]->{hashname} = '__STRING' . ++$_[1]->{strcount} . '__'; }
sub issubrule { undef }
sub isterminal { 1 }
sub describe ($) { shift->{'description'} }
sub new ($$$$)
{
my $class = ref($_[0]) || $_[0];
my $pattern = $_[1];
my $desc = $pattern;
$desc=~s/\\/\\\\/g;
$desc=~s/}/\\}/g;
$desc=~s/{/\\{/g;
bless
{
"pattern" => $pattern,
"lookahead" => $_[2],
"line" => $_[3],
"description" => "'$desc'",
}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule, $check) = @_;
my $code = '
Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe
. ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '},
$tracelevel)
if defined $::RD_TRACE;
undef $lastsep;
$expectation->is(q{' . ($rule->hasleftmost($self) ? ''
: $self->describe ) . '})->at($text);
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . '
' . ($self->{"lookahead"}<0?'if':'unless')
. ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and '
. ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '')
. ' $text =~ m/\A' . quotemeta($self->{"pattern"}) . '/)
{
'.($self->{"lookahead"} ? '$text = $_savetext;' : '$text = $lastsep . $text if defined $lastsep;').'
'. ($check->{itempos} ? Parse::RecDescent::Production::unincitempos() : '') . '
$expectation->failed();
Parse::RecDescent::_trace(qq{<<Didn\'t match terminal>>},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
last;
}
$current_match = substr($text, $-[0], $+[0] - $-[0]);
substr($text,0,length($current_match),q{});
Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
. $current_match . q{])},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
push @item, $item{'.$self->{hashname}.'}=$current_match;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
';
return $code;
}
1;
package Parse::RecDescent::InterpLit;
sub sethashname { $_[0]->{hashname} = '__STRING' . ++$_[1]->{strcount} . '__'; }
sub issubrule { undef }
sub isterminal { 1 }
sub describe ($) { shift->{'description'} }
sub new ($$$$)
{
my $class = ref($_[0]) || $_[0];
my $pattern = $_[1];
$pattern =~ s#/#\\/#g;
my $desc = $pattern;
$desc=~s/\\/\\\\/g;
$desc=~s/}/\\}/g;
$desc=~s/{/\\{/g;
bless
{
"pattern" => $pattern,
"lookahead" => $_[2],
"line" => $_[3],
"description" => "'$desc'",
}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule, $check) = @_;
my $code = '
Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe
. ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '},
$tracelevel)
if defined $::RD_TRACE;
undef $lastsep;
$expectation->is(q{' . ($rule->hasleftmost($self) ? ''
: $self->describe ) . '})->at($text);
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . '
' . ($self->{"lookahead"}<0?'if':'unless')
. ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and '
. ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '')
. ' do { $_tok = "' . $self->{"pattern"} . '"; 1 } and
substr($text,0,length($_tok)) eq $_tok and
do { substr($text,0,length($_tok)) = ""; 1; }
)
{
'.($self->{"lookahead"} ? '$text = $_savetext;' : '$text = $lastsep . $text if defined $lastsep;').'
'. ($check->{itempos} ? Parse::RecDescent::Production::unincitempos() : '') . '
$expectation->failed();
Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
last;
}
Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
. $_tok . q{])},
Parse::RecDescent::_tracefirst($text))
if defined $::RD_TRACE;
push @item, $item{'.$self->{hashname}.'}=$_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
';
return $code;
}
1;
package Parse::RecDescent::Subrule;
sub issubrule ($) { return $_[0]->{"subrule"} }
sub isterminal { 0 }
sub sethashname {}
sub describe ($)
{
my $desc = $_[0]->{"implicit"} || $_[0]->{"subrule"};
$desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
return $desc;
}
sub callsyntax($$)
{
if ($_[0]->{"matchrule"})
{
return "&{'$_[1]'.qq{$_[0]->{subrule}}}";
}
else
{
return $_[1].$_[0]->{"subrule"};
}
}
sub new ($$$$;$$$)
{
my $class = ref($_[0]) || $_[0];
bless
{
"subrule" => $_[1],
"lookahead" => $_[2],
"line" => $_[3],
"implicit" => $_[4] || undef,
"matchrule" => $_[5],
"argcode" => $_[6] || undef,
}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule, $check) = @_;
'
Parse::RecDescent::_trace(q{Trying subrule: [' . $self->{"subrule"} . ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} . '},
$tracelevel)
if defined $::RD_TRACE;
if (1) { no strict qw{refs};
$expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
# WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
: 'q{'.$self->describe.'}' ) . ')->at($text);
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' )
. ($self->{"lookahead"}<0?'if':'unless')
. ' (defined ($_tok = '
. $self->callsyntax($namespace.'::')
. '($thisparser,$text,$repeating,'
. ($self->{"lookahead"}?'1':'$_noactions')
. ($self->{argcode} ? ",sub { return $self->{argcode} }"
: ',sub { \\@arg }')
. ($check->{"itempos"}?',$itempos[$#itempos]':',undef')
. ')))
{
'.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
Parse::RecDescent::_trace(q{<<'.Parse::RecDescent::_matchtracemessage($self,1).' subrule: ['
. $self->{subrule} . ']>>},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'},
$tracelevel)
if defined $::RD_TRACE;
$expectation->failed();
last;
}
Parse::RecDescent::_trace(q{>>'.Parse::RecDescent::_matchtracemessage($self).' subrule: ['
. $self->{subrule} . ']<< (return value: [}
. $_tok . q{]},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'},
$tracelevel)
if defined $::RD_TRACE;
$item{q{' . $self->{subrule} . '}} = $_tok;
push @item, $_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
}
'
}
package Parse::RecDescent::Repetition;
sub issubrule ($) { return $_[0]->{"subrule"} }
sub isterminal { 0 }
sub sethashname { }
sub describe ($)
{
my $desc = $_[0]->{"expected"} || $_[0]->{"subrule"};
$desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
return $desc;
}
sub callsyntax($$)
{
if ($_[0]->{matchrule})
{ return "sub { goto &{''.qq{$_[1]$_[0]->{subrule}}} }"; }
else
{ return "\\&$_[1]$_[0]->{subrule}"; }
}
sub new ($$$$$$$$$$)
{
my ($self, $subrule, $repspec, $min, $max, $lookahead, $line, $parser, $matchrule, $argcode) = @_;
my $class = ref($self) || $self;
($max, $min) = ( $min, $max) if ($max<$min);
my $desc;
if ($subrule=~/\A_alternation_\d+_of_production_\d+_of_rule/)
{ $desc = $parser->{"rules"}{$subrule}->expected }
if ($lookahead)
{
if ($min>0)
{
return new Parse::RecDescent::Subrule($subrule,$lookahead,$line,$desc,$matchrule,$argcode);
}
else
{
Parse::RecDescent::_error("Not symbol (\"!\") before
\"$subrule\" doesn't make
sense.",$line);
Parse::RecDescent::_hint("Lookahead for negated optional
repetitions (such as
\"!$subrule($repspec)\" can never
succeed, since optional items always
match (zero times at worst).
Did you mean a single \"!$subrule\",
instead?");
}
}
bless
{
"subrule" => $subrule,
"repspec" => $repspec,
"min" => $min,
"max" => $max,
"lookahead" => $lookahead,
"line" => $line,
"expected" => $desc,
"argcode" => $argcode || undef,
"matchrule" => $matchrule,
}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule, $check) = @_;
my ($subrule, $repspec, $min, $max, $lookahead) =
@{$self}{ qw{subrule repspec min max lookahead} };
'
Parse::RecDescent::_trace(q{Trying repeated subrule: [' . $self->describe . ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} . '},
$tracelevel)
if defined $::RD_TRACE;
$expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
# WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
: 'q{'.$self->describe.'}' ) . ')->at($text);
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
unless (defined ($_tok = $thisparser->_parserepeat($text, '
. $self->callsyntax($namespace.'::')
. ', ' . $min . ', ' . $max . ', '
. ($self->{"lookahead"}?'1':'$_noactions')
. ',$expectation,'
. ($self->{argcode} ? "sub { return $self->{argcode} }"
: 'sub { \\@arg }')
. ($check->{"itempos"}?',$itempos[$#itempos]':',undef')
. ')))
{
Parse::RecDescent::_trace(q{<<'.Parse::RecDescent::_matchtracemessage($self,1).' repeated subrule: ['
. $self->describe . ']>>},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'},
$tracelevel)
if defined $::RD_TRACE;
last;
}
Parse::RecDescent::_trace(q{>>'.Parse::RecDescent::_matchtracemessage($self).' repeated subrule: ['
. $self->{subrule} . ']<< (}
. @$_tok . q{ times)},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'},
$tracelevel)
if defined $::RD_TRACE;
$item{q{' . "$self->{subrule}($self->{repspec})" . '}} = $_tok;
push @item, $_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
'
}
package Parse::RecDescent::Result;
sub issubrule { 0 }
sub isterminal { 0 }
sub describe { '' }
sub new
{
my ($class, $pos) = @_;
bless {}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule) = @_;
'
$return = $item[-1];
';
}
package Parse::RecDescent::Operator;
my @opertype = ( " non-optional", "n optional" );
sub issubrule { 0 }
sub isterminal { 0 }
sub describe { $_[0]->{"expected"} }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; }
sub new
{
my ($class, $type, $minrep, $maxrep, $leftarg, $op, $rightarg) = @_;
bless
{
"type" => "${type}op",
"leftarg" => $leftarg,
"op" => $op,
"min" => $minrep,
"max" => $maxrep,
"rightarg" => $rightarg,
"expected" => "<${type}op: ".$leftarg->describe." ".$op->describe." ".$rightarg->describe.">",
}, $class;
}
sub code($$$$)
{
my ($self, $namespace, $rule, $check) = @_;
my @codeargs = @_[1..$#_];
my ($leftarg, $op, $rightarg) =
@{$self}{ qw{leftarg op rightarg} };
my $code = '
Parse::RecDescent::_trace(q{Trying operator: [' . $self->describe . ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} . '},
$tracelevel)
if defined $::RD_TRACE;
$expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
# WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
: 'q{'.$self->describe.'}' ) . ')->at($text);
$_tok = undef;
OPLOOP: while (1)
{
$repcount = 0;
my @item;
my %item;
';
$code .= '
my $_itempos = $itempos[-1];
my $itemposfirst;
' if $check->{itempos};
if ($self->{type} eq "leftop" )
{
$code .= '
# MATCH LEFTARG
' . $leftarg->code(@codeargs) . '
';
$code .= '
if (defined($_itempos) and !defined($itemposfirst))
{
$itemposfirst = Parse::RecDescent::Production::_duplicate_itempos($_itempos);
}
' if $check->{itempos};
$code .= '
$repcount++;
inc/Parse/RecDescent.pm view on Meta::CPAN
# MATCH RIGHTARG
' . $rightarg->code(@codeargs) . '
$repcount++;
';
}
$code .= 'unless (@item) { undef $_tok; last }' unless $self->{min}==0;
$code .= '
$_tok = [ @item ];
';
$code .= '
if (defined $itemposfirst)
{
Parse::RecDescent::Production::_update_itempos(
$_itempos, $itemposfirst, undef, [qw(from)]);
}
' if $check->{itempos};
$code .= '
last;
} # end of OPLOOP
';
$code .= '
unless ($repcount>='.$self->{min}.')
{
Parse::RecDescent::_trace(q{<<'.Parse::RecDescent::_matchtracemessage($self,1).' operator: ['
. $self->describe
. ']>>},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'},
$tracelevel)
if defined $::RD_TRACE;
$expectation->failed();
last;
}
Parse::RecDescent::_trace(q{>>'.Parse::RecDescent::_matchtracemessage($self).' operator: ['
. $self->describe
. ']<< (return value: [}
. qq{@{$_tok||[]}} . q{]},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'},
$tracelevel)
if defined $::RD_TRACE;
push @item, $item{'.($self->{name}||$self->{hashname}).'}=$_tok||[];
';
return $code;
}
package Parse::RecDescent::Expectation;
sub new ($)
{
bless {
"failed" => 0,
"expected" => "",
"unexpected" => "",
"lastexpected" => "",
"lastunexpected" => "",
"defexpected" => $_[1],
};
}
sub is ($$)
{
$_[0]->{lastexpected} = $_[1]; return $_[0];
}
sub at ($$)
{
$_[0]->{lastunexpected} = $_[1]; return $_[0];
}
sub failed ($)
{
return unless $_[0]->{lastexpected};
$_[0]->{expected} = $_[0]->{lastexpected} unless $_[0]->{failed};
$_[0]->{unexpected} = $_[0]->{lastunexpected} unless $_[0]->{failed};
$_[0]->{failed} = 1;
}
sub message ($)
{
my ($self) = @_;
$self->{expected} = $self->{defexpected} unless $self->{expected};
$self->{expected} =~ s/_/ /g;
if (!$self->{unexpected} || $self->{unexpected} =~ /\A\s*\Z/s)
{
return "Was expecting $self->{expected}";
}
else
{
$self->{unexpected} =~ /\s*(.*)/;
return "Was expecting $self->{expected} but found \"$1\" instead";
}
}
1;
package Parse::RecDescent;
use Carp;
use vars qw ( $AUTOLOAD $VERSION $_FILENAME);
my $ERRORS = 0;
our $VERSION = '1.967009';
$VERSION = eval $VERSION;
$_FILENAME=__FILE__;
# BUILDING A PARSER
my $nextnamespace = "namespace000001";
sub _nextnamespace()
{
return "Parse::RecDescent::" . $nextnamespace++;
}
# ARGS ARE: $class, $grammar, $compiling, $namespace
sub new ($$$$)
{
my $class = ref($_[0]) || $_[0];
local $Parse::RecDescent::compiling = $_[2];
my $name_space_name = defined $_[3]
? "Parse::RecDescent::".$_[3]
: _nextnamespace();
my $self =
{
"rules" => {},
"namespace" => $name_space_name,
"startcode" => '',
"localvars" => '',
"_AUTOACTION" => undef,
"_AUTOTREE" => undef,
# Precompiled parsers used to set _precompiled, but that
# wasn't present in some versions of Parse::RecDescent used to
# build precompiled parsers. Instead, set a new
# _not_precompiled flag, which is remove from future
# Precompiled parsers at build time.
"_not_precompiled" => 1,
};
if ($::RD_AUTOACTION) {
my $sourcecode = $::RD_AUTOACTION;
$sourcecode = "{ $sourcecode }"
unless $sourcecode =~ /\A\s*\{.*\}\s*\Z/;
$self->{_check}{itempos} =
$sourcecode =~ /\@itempos\b|\$itempos\s*\[/;
$self->{_AUTOACTION}
= new Parse::RecDescent::Action($sourcecode,0,-1)
}
bless $self, $class;
return $self->Replace($_[1])
}
sub Compile($$$$) {
die "Compilation of Parse::RecDescent grammars not yet implemented\n";
}
sub DESTROY {
my ($self) = @_;
my $namespace = $self->{namespace};
$namespace =~ s/Parse::RecDescent:://;
if ($self->{_not_precompiled}) {
# BEGIN WORKAROUND
# Perl has a bug that creates a circular reference between
# @ISA and that variable's stash:
# https://rt.perl.org/rt3/Ticket/Display.html?id=92708
# Emptying the array before deleting the stash seems to
# prevent the leak. Once the ticket above has been resolved,
# these two lines can be removed.
no strict 'refs';
@{$self->{namespace} . '::ISA'} = ();
# END WORKAROUND
# Some grammars may contain circular references between rules,
# such as:
# a: 'ID' | b
# b: '(' a ')'
# Unless these references are broken, the subs stay around on
# stash deletion below. Iterate through the stash entries and
# for each defined code reference, set it to reference sub {}
# instead.
{
local $^W; # avoid 'sub redefined' warnings.
my $blank_sub = sub {};
while (my ($name, $glob) = each %{"Parse::RecDescent::$namespace\::"}) {
*$glob = $blank_sub if defined &$glob;
}
}
# Delete the namespace's stash
delete $Parse::RecDescent::{$namespace.'::'};
}
}
# BUILDING A GRAMMAR....
# ARGS ARE: $self, $grammar, $isimplicit, $isleftop
sub Replace ($$)
{
# set $replace = 1 for _generate
splice(@_, 2, 0, 1);
return _generate(@_);
}
# ARGS ARE: $self, $grammar, $isimplicit, $isleftop
sub Extend ($$)
{
# set $replace = 0 for _generate
splice(@_, 2, 0, 0);
inc/Parse/RecDescent.pm view on Meta::CPAN
_parse("an perl codeblock marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
$item = new Parse::RecDescent::Directive(
'Text::Balanced::extract_codeblock($text,undef,$skip,\''.$outer.'\');
', $lookahead,$line,"<perl_codeblock>");
$prod and $prod->additem($item)
or _no_rule("<perl_codeblock>",$line);
}
elsif ($grammar =~ m/$VARIABLEMK/gco)
{
_parse("an perl variable marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
$item = new Parse::RecDescent::Directive(
'Text::Balanced::extract_variable($text,$skip);
', $lookahead,$line,"<perl_variable>");
$prod and $prod->additem($item)
or _no_rule("<perl_variable>",$line);
}
elsif ($grammar =~ m/$NOCHECKMK/gco)
{
_parse("a disable checking marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
if ($rule)
{
_error("<nocheck> directive not at start of grammar", $line);
_hint("The <nocheck> directive can only
be specified at the start of a
grammar (before the first rule
is defined.");
}
else
{
local $::RD_CHECK = 1;
}
}
elsif ($grammar =~ m/$AUTOSTUBMK/gco)
{
_parse("an autostub marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
$::RD_AUTOSTUB = "";
}
elsif ($grammar =~ m/$AUTORULEMK/gco)
{
_parse("an autorule marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
$::RD_AUTOSTUB = $1;
}
elsif ($grammar =~ m/$AUTOTREEMK/gco)
{
my $base = defined($1) ? $1 : "";
my $current_match = substr($grammar, $-[0], $+[0] - $-[0]);
$base .= "::" if $base && $base !~ /::$/;
_parse("an autotree marker", $aftererror,$line, $current_match);
if ($rule)
{
_error("<autotree> directive not at start of grammar", $line);
_hint("The <autotree> directive can only
be specified at the start of a
grammar (before the first rule
is defined.");
}
else
{
undef $self->{_AUTOACTION};
$self->{_AUTOTREE}{NODE}
= new Parse::RecDescent::Action(q({bless \%item, ').$base.q('.$item[0]}),0,-1);
$self->{_AUTOTREE}{TERMINAL}
= new Parse::RecDescent::Action(q({bless {__VALUE__=>$item[1]}, ').$base.q('.$item[0]}),0,-1);
}
}
elsif ($grammar =~ m/$REJECTMK/gco)
{
_parse("an reject marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
$item = new Parse::RecDescent::UncondReject($lookahead,$line,"<reject>");
$prod and $prod->additem($item)
or _no_rule("<reject>",$line);
}
elsif ($grammar =~ m/(?=$CONDREJECTMK)/gco
and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
$code })
{
_parse("a (conditional) reject marker", $aftererror,$line, $code );
$code =~ /\A\s*<reject:(.*)>\Z/s;
my $cond = $1;
$item = new Parse::RecDescent::Directive(
"($1) ? undef : 1", $lookahead,$line,"<reject:$cond>");
$prod and $prod->additem($item)
or _no_rule("<reject:$cond>",$line);
}
elsif ($grammar =~ m/(?=$SCOREMK)/gco
and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
$code })
{
_parse("a score marker", $aftererror,$line, $code );
$code =~ /\A\s*<score:(.*)>\Z/s;
$prod and $prod->addscore($1, $lookahead, $line)
or _no_rule($code,$line);
}
elsif ($grammar =~ m/(?=$AUTOSCOREMK)/gco
and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
$code;
} )
{
_parse("an autoscore specifier", $aftererror,$line,$code);
$code =~ /\A\s*<autoscore:(.*)>\Z/s;
$rule and $rule->addautoscore($1,$self)
or _no_rule($code,$line);
$item = new Parse::RecDescent::UncondReject($lookahead,$line,$code);
$prod and $prod->additem($item)
or _no_rule($code,$line);
}
elsif ($grammar =~ m/$RESYNCMK/gco)
{
_parse("a resync to newline marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
$item = new Parse::RecDescent::Directive(
'if ($text =~ s/(\A[^\n]*\n)//) { $return = 0; $1; } else { undef }',
$lookahead,$line,"<resync>");
$prod and $prod->additem($item)
or _no_rule("<resync>",$line);
}
elsif ($grammar =~ m/(?=$RESYNCPATMK)/gco
and do { ($code) = extract_bracketed($grammar,'<');
$code })
{
_parse("a resync with pattern marker", $aftererror,$line, $code );
( run in 2.573 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )