# GENERATE RECURSIVE DESCENT PARSER OBJECTS FROM A GRAMMARC
# SEE RecDescent.pod FOR FULL DETAILS
package Parse
::RecDescent
;
use Text
::Balanced qw
( extract_codeblock extract_bracketed extract_quotelike extract_delimited
);
*defskip
= \
'\s*'; # DEFAULT SEPARATOR IS OPTIONAL WHITESPACE
$skip = '\s*'; # UNIVERSAL SEPARATOR IS OPTIONAL WHITESPACE
my $MAXREP = 100_000_000
; # REPETITIONS MATCH AT MOST 100,000,000 TIMES
sub import
# IMPLEMENT PRECOMPILER BEHAVIOUR UNDER:
# perl -MParse::RecDescent - <grammarfile> <classname>
local *_die
= sub { print @_, "\n"; exit };
my ($package, $file, $line) = caller;
if (substr($file,0,1) eq '-' && $line == 0)
_die
("Usage: perl -MLocalTest - <grammarfile> <classname>")
my ($sourcefile, $class) = @ARGV;
or _die
("Can't open grammar file '$sourcefile'");
my $grammar = join '', <IN
>;
Parse
::RecDescent
->Precompile($grammar, $class, $sourcefile);
$self->Precompile(undef,$class);
my ($self, $grammar, $class, $sourcefile) = @_;
$class =~ /^(\w+::)*\w+$/ or croak
("Bad class name: $class");
or croak
("Can't write to new module file '$modulefile'");
print STDERR
"precompiling grammar from file '$sourcefile'\n",
"to class $class in module file '$modulefile'\n"
if $grammar && $sourcefile;
$self = Parse
::RecDescent
->new($grammar,1)
|| croak
("Can't compile bad grammar")
foreach ( keys %{$self->{rules
}} )
{ $self->{rules
}{$_}{changed
} = 1 }
print OUT
"package $class;\nuse Parse::RecDescent;\n\n";
print OUT
"{ my \$ERRORS;\n\n";
print OUT
$self->_code();
print OUT
"}\npackage $class; sub new { ";
print OUT Data
::Dumper
->Dump([$self], [qw(self)]);
or croak
("Can't write to new module file '$modulefile'");
package Parse
::RecDescent
::LineCounter
;
sub TIESCALAR
# ($classname, \$text, $thisparser, $prevflag)
my $parser = $_[0]->{parser
};
my $from = $parser->{fulltextlen
}-length(${$_[0]->{text
}})-$_[0]->{prev
};
$parser->{lastlinenum
} = $parser->{offsetlinenum
}
- Parse
::RecDescent
::_linecount
(substr($parser->{fulltext
},$from))
my $parser = $_[0]->{parser
};
$parser->{offsetlinenum
} -= $parser->{lastlinenum
} - $_[1];
sub resync
# ($linecounter)
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
}})
$parser->{offsetlinenum
} += $parser->{lastlinenum
} - $apparently;
package Parse
::RecDescent
::ColCounter
;
sub TIESCALAR
# ($classname, \$text, $thisparser, $prevflag)
my $parser = $_[0]->{parser
};
my $missing = $parser->{fulltextlen
}-length(${$_[0]->{text
}})-$_[0]->{prev
}+1;
substr($parser->{fulltext
},0,$missing) =~ m/^(.*)\Z/m;
die "Can't set column number via \$thiscolumn\n";
package Parse
::RecDescent
::OffsetCounter
;
sub TIESCALAR
# ($classname, \$text, $thisparser, $prev)
my $parser = $_[0]->{parser
};
return $parser->{fulltextlen
}-length(${$_[0]->{text
}})+$_[0]->{prev
};
die "Can't set current offset via \$thisoffset or \$prevoffset\n";
package Parse
::RecDescent
::Rule
;
my $class = ref($_[0]) || $_[0];
if (defined $owner->{"rules"}{$name})
my $self = $owner->{"rules"}{$name};
if ($replace && !$self->{"changed"})
return $owner->{"rules"}{$name} =
@
{$_[0]->{"prods"}} = ();
@
{$_[0]->{"calls"}} = ();
foreach $prod ( @
{$self->{"prods"}} )
return 1 if $prod->hasleftmost($ref);
foreach $prod ( @
{$self->{"prods"}} )
push @subrules, $prod->leftmostsubrule();
foreach $prod ( @
{$self->{"prods"}} )
my $next = $prod->expected();
unless (! $next or _contains
($next,@expected) )
return join ', or ', @expected;
foreach $item ( @_ ) { return 1 if $target eq $item; }
my ( $self, $subrule ) = @_;
unless ( _contains
($subrule, @
{$self->{"calls"}}) )
push @
{$self->{"calls"}}, $subrule;
my ( $self, $prod ) = @_;
push @
{$self->{"prods"}}, $prod;
$prod->{"number"} = $#{$self->{"prods"}};
my ( $self, $var, $parser ) = @_;
if ($var =~ /\A\s*local\s+([%@\$]\w+)/)
$parser->{localvars
} .= " $1";
$self->{"vars"} .= "$var;\n" }
{ $self->{"vars"} .= "my $var;\n" }
my ( $self, $code ) = @_;
$self->{"autoscore"} = $code;
my $prodcount = scalar @
{$self->{"prods"}};
my $opcount = ++$self->{"opcount"};
return "_operator_${opcount}_of_production_${prodcount}_of_rule_$self->{name}";
my $prodcount = scalar @
{$self->{"prods"}};
my $impcount = ++$self->{"impcount"};
return "_alternation_${impcount}_of_production_${prodcount}_of_rule_$self->{name}";
my ($self, $namespace, $parser) = @_;
eval 'undef &' . $namespace . '::' . $self->{"name"};
# ARGS ARE: ($parser, $text; $repeating, $_noactions, \@args)
sub ' . $namespace . '::' . $self->{"name"} . '
my $thisrule = $thisparser->{"rules"}{"' . $self->{"name"} . '"};
Parse::RecDescent::_trace(q{Trying rule: [' . $self->{"name"} . ']},
Parse::RecDescent::_tracefirst($_[1]),
q{' . $self->{"name"} . '})
' . ($parser->{deferrable
}
?
'my $def_at = @{$thisparser->{deferred}};'
my $err_at = @{$thisparser->{errors}};
my $repeating = defined($_[2]) && $_[2];
my $_noactions = defined($_[3]) && $_[3];
my @arg = defined $_[4] ? @{ &{$_[4]} } : ();
my %arg = ($#arg & 01) ? @arg : (@arg, undef);
my $expectation = new Parse::RecDescent::Expectation($thisrule->expected());
'. ($parser->{_check
}{thisoffset
}?
'
tie $thisoffset, q{Parse::RecDescent::OffsetCounter}, \
$text, $thisparser;
':'') . ($parser->{_check}{prevoffset}?'
tie
$prevoffset, q{Parse::RecDescent::OffsetCounter}, \
$text, $thisparser, 1;
':'') . ($parser->{_check}{thiscolumn}?'
tie
$thiscolumn, q{Parse::RecDescent::ColCounter}, \
$text, $thisparser;
':'') . ($parser->{_check}{prevcolumn}?'
tie
$prevcolumn, q{Parse::RecDescent::ColCounter}, \
$text, $thisparser, 1;
':'') . ($parser->{_check}{prevline}?'
tie
$prevline, q{Parse::RecDescent::LineCounter}, \
$text, $thisparser, 1;
tie
$thisline, q{Parse::RecDescent::LineCounter}, \
$text, $thisparser;
foreach $prod ( @{$self->{"prods"}} )
$prod->addscore($self->{autoscore},0,0) if $self->{autoscore};
next unless $prod->checkleftmost();
$code .= $prod->code($namespace,$self,$parser);
$code .= $parser->{deferrable}
@
{$thisparser->{deferred
}}, $def_at unless $_matched;
unless ( $_matched || defined($return) || defined($score) )
' .($parser->{deferrable}
? ' splice @
{$thisparser->{deferred
}}, $def_at;
$_[1] = $text; # NOT SURE THIS IS NEEDED
Parse
::RecDescent
::_trace
(q{<<Didn\'t match rule>>},
Parse::RecDescent::_tracefirst($_[1]),
q{' . $self->{"name"} .'})
if (!defined($return) && defined($score))
Parse::RecDescent::_trace(q{>>Accepted scored production<<}, "",
q{' . $self->{"name"} .'})
splice @{$thisparser->{errors}}, $err_at;
$return = $item[$#item] unless defined $return;
Parse::RecDescent::_trace(q{>>Matched rule<< (return value: [} .
q{' . $self->{"name"} .'});
Parse::RecDescent::_trace(q{(consumed: [} .
Parse
::RecDescent
::_tracemax
(substr($_[1],0,-length($text))) . q{])},
Parse
::RecDescent
::_tracefirst
($text),
, q{' . $self->{"name"} .'})
my $root = $self->{"name"};
@left = $self->leftmostsubrules();
next unless defined $rules->{$next}; # SKIP NON-EXISTENT RULES
return 1 if $next eq $root;
foreach $child ( $rules->{$next}->leftmostsubrules() )
if ! _contains($child, @left) ;
package Parse::RecDescent::Production;
return join ' ', map { $_->describe($_[1]) or () } @{$_[0]->{items}};
my ($self, $line, $uncommit, $error) = @_;
my $class = ref($self) || $self;
my $itemcount = scalar @{$_[0]->{"items"}};
return ($itemcount) ? $_[0]->{"items"}[0]->describe(1) : '';
return ${$self->{"items"}}[0] eq $ref if scalar @{$self->{"items"}};
if ( $#{$self->{"items"}} >= 0 )
my $subrule = $self->{"items"}[0]->issubrule();
return $subrule if defined $subrule;
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
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
Parse::RecDescent::UncondReject->new(0,0,'<reject>');
elsif (@items==1 && ($items[0]->describe||"") =~ /<rulevar|<autoscore/)
( ref($items[0]) =~ /\AParse::RecDescent::UncondReject/
|| ($items[0]->describe||"") =~ /<autoscore/
Parse::RecDescent::_warn(1,"Optimizing away production: [". $_[0]->describe ."]");
my $what = $items[0]->describe =~ /<rulevar/
? "a <rulevar> (which acts like an unconditional <reject> during parsing)"
: $items[0]->describe =~ /<autoscore/
? "an <autoscore> (which acts like an unconditional <reject> during parsing)"
: "an unconditional <reject>";
my $caveat = $items[0]->describe =~ /<rulevar/
? " after the specified variable was set up"
? "However, there were also other (useless) items after the leading "
. ", so you may have been expecting some other behaviour."
: "You can safely ignore this message.";
Parse::RecDescent::_hint("The production starts with $what. That means that the
production can never successfully match, so it was
optimized out of the final parser$caveat. $advice");
foreach $item (@{$_[0]->{"items"}})
if (ref($item) =~ /Parse::RecDescent::(Action|Directive)/)
return 1 if $item->{code} =~ /\$skip/;
my ( $self, $whichop, $line ) = @_;
{ type=>$whichop, line=>$line,
offset=> scalar(@{$self->{items}}) };
my ( $self, $code, $lookahead, $line ) = @_;
$self->additem(Parse::RecDescent::Directive->new(
my \$thisscore = do { $code } + 0;
if (!defined(\$score) || \$thisscore>\$score)
{ \$score=\$thisscore; \$score_return=\$item[-1]; }
undef;", $lookahead, $line,"<score: $code>") )
unless $self->{items}[-1]->describe =~ /<score/;
my ( $self, $line ) = @_;
while (my $next = pop @{$self->{op}})
Parse::RecDescent::_error("Incomplete <$next->{type}op:...>.", $line);
Parse::RecDescent::_hint(
"The current production ended without completing the
<$next->{type}op:...> directive that started near line
$next->{line}. Did you forget the closing '>'?");
my ( $self, $line, $minrep, $maxrep ) = @_;
Parse::RecDescent::_error("Unmatched > found.", $line);
Parse::RecDescent::_hint(
"A '>' angle bracket was encountered, which typically
indicates the end of a directive. However no suitable
preceding directive was encountered. Typically this
indicates either a extra '>' in the grammar, or a
problem inside the previous directive.");
my $op = pop @{$self->{op}};
my $span = @{$self->{items}} - $op->{offset};
if ($op->{type} =~ /left|right/)
Parse::RecDescent::_error(
"Incorrect <$op->{type}op:...> specification:
expected 3 args, but found $span instead", $line);
Parse::RecDescent::_hint(
"The <$op->{type}op:...> directive requires a
sequence of exactly three elements. For example:
<$op->{type}op:leftarg /op/ rightarg>");
Parse::RecDescent::Operator->new(
$op->{type}, $minrep, $maxrep, splice(@{$self->{"items"}}, -3));
$self->{items}[-1]->sethashname($self);
my ( $self, $line ) = @_;
unless (@{$self->{items}})
Parse::RecDescent::_error(
"Incorrect <return:...> specification:
expected item missing", $line);
Parse::RecDescent::_hint(
"The <return:...> directive requires a
sequence of at least one item. For example:
Parse::RecDescent::Result->new();
my ( $self, $item ) = @_;
$item->sethashname($self);
push @{$self->{"items"}}, $item;
push @itempos, {'offset' => {'from'=>$thisoffset, 'to'=>undef},
'line' => {'from'=>$thisline, 'to'=>undef},
'column' => {'from'=>$thiscolumn, 'to'=>undef} };
$itempos[$#itempos]{'offset'}{'from'} += length($1);
$itempos[$#itempos]{'line'}{'from'} = $thisline;
$itempos[$#itempos]{'column'}{'from'} = $thiscolumn;
$itempos[$#itempos]{'offset'}{'to'} = $prevoffset;
$itempos[$#itempos]{'line'}{'to'} = $prevline;
$itempos[$#itempos]{'column'}{'to'} = $prevcolumn;
my ($self,$namespace,$rule,$parser) = @_;
. (defined $self->{"uncommit"} ? '' : ' && !$commit')
? 'local $skip = defined($skip) ? $skip : $Parse::RecDescent::skip;'
Parse::RecDescent::_trace(q{Trying production: ['
Parse::RecDescent::_tracefirst($_[1]),
q{' . $rule ->{name}. '})
my $thisprod = $thisrule->{"prods"}[' . $self->{"number"} . '];
' . (defined $self->{"error"} ? '' : '$text = $_[1];' ) . '
@item = (q{' . $rule->{"name"} . '});
%item = (__RULE__ => q{' . $rule->{"name"} . '});
' if $parser->{_check}{itempos};
for ($i = 0; $i < @{$self->{"items"}}; $i++)
$item = ${$self->{items}}[$i];
$code .= preitempos() if $parser->{_check}{itempos};
$code .= $item->code($namespace,$rule,$parser->{_check});
$code .= postitempos() if $parser->{_check}{itempos};
if ($parser->{_AUTOACTION} && defined($item) && !$item->isa("Parse::RecDescent::Action"))
$code .= $parser->{_AUTOACTION}->code($namespace,$rule);
Parse::RecDescent::_warn(1,"Autogenerating action in rule
$parser->{_AUTOACTION}{code}")
Parse::RecDescent::_hint("The \$::RD_AUTOACTION was defined,
so any production not ending in an
explicit action has the specified
\"auto-action\" automatically
elsif ($parser->{_AUTOTREE} && defined($item) && !$item->isa("Parse::RecDescent::Action"))
if ($i==1 && $item->isterminal)
$code .= $parser->{_AUTOTREE}{TERMINAL}->code($namespace,$rule);
$code .= $parser->{_AUTOTREE}{NODE}->code($namespace,$rule);
Parse::RecDescent::_warn(1,"Autogenerating tree-building action in rule
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.");
Parse::RecDescent::_trace(q{>>Matched production: ['
. $self->describe . ']<<},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '})
package Parse::RecDescent::Action;
sub sethashname { $_[0]->{hashname} = '__ACTION' . ++$_[1]->{actcount} .'__'; }
my $class = ref($_[0]) || $_[0];
my ($self, $namespace, $rule) = @_;
Parse::RecDescent::_trace(q{Trying action},
Parse
::RecDescent
::_tracefirst
($text),
q{' . $rule->{name} . '})
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
$_tok = ($_noactions) ? 0 : do ' . $self->{"code"} . ';
' . ($self->{"lookahead"}<0?'if':'unless') . ' (defined $_tok)
Parse::RecDescent::_trace(q{<<Didn\'t match action>> (return value: [undef])})
Parse::RecDescent::_trace(q{>>Matched action<< (return value: [}
' . ($self->{line}>=0 ? '$item{'. $self->{hashname} .'}=$_tok;' : '' ) .'
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
package Parse::RecDescent::Directive;
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE
' . ++$_[1]->{dircount} . '__
'; }
sub describe { $_[1] ? '' : $_[0]->{name} }
my $class = ref($_[0]) || $_[0];
my ($self, $namespace, $rule) = @_;
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
Parse
::RecDescent
::_trace
(q{Trying directive: ['
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '})
if defined $::RD_TRACE; ' .'
$_tok = do { ' . $self->{"code"} . ' };
Parse::RecDescent::_trace(q{>>Matched directive<< (return value: [}
Parse
::RecDescent
::_tracefirst
($text))
Parse
::RecDescent
::_trace
(q{<<Didn\'t match directive>>},
Parse::RecDescent::_tracefirst($text))
' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
. ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
push @item, $item{'.$self->{hashname}.'}=$_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
package Parse::RecDescent::UncondReject;
sub describe { $_[1] ? '' : $_[0]->{name} }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; }
my $class = ref($_[0]) || $_[0];
# MARK, YOU MAY WANT TO OPTIMIZE THIS.
my ($self, $namespace, $rule) = @_;
Parse::RecDescent::_trace(q{>>Rejecting production<< (found '
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '})
' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
. ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
package Parse::RecDescent::Error;
sub describe { $_[1] ? '' : $_[0]->{commitonly} ? '<error?:...>' : '<error...>' }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; }
my $class = ref($_[0]) || $_[0];
my ($self, $namespace, $rule) = @_;
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
#WAS: Parse::RecDescent::_error("Invalid $rule: " . $expectation->message() ,$thisline);
push @{$thisparser->{errors}}, ["Invalid $rule: " . $expectation->message() ,$thisline];
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);
package Parse::RecDescent::Token;
sub sethashname { $_[0]->{hashname} = '__PATTERN' . ++$_[1]->{patcount} . '__'; }
sub describe ($) { shift->{'description'}}
# ARGS ARE: $self, $pattern, $left_delim, $modifiers, $lookahead, $linenum
my $class = ref($_[0]) || $_[0];
if ($ldel eq '/') { $desc = "$ldel$pattern$rdel$mod" }
else { $desc = "m$ldel$pattern$rdel$mod" }
local \$SIG{__WARN__} = sub {0};
'' =~ m$ldel$pattern$rdel" and $@)
Parse::RecDescent::_warn(3, "Token pattern \"m$ldel$pattern$rdel\"
may not be a valid regular expression",
Parse::RecDescent::_hint($@);
# QUIETLY PREVENT (WELL-INTENTIONED) CALAMITY
$pattern =~ s/(\A|[^\\])\\G/$1/g;
my ($self, $namespace, $rule, $check) = @_;
my $ldel = $self->{"ldelim"};
my $rdel = $self->{"rdelim"};
my $mod = $self->{"mod"};
Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe
. ']}, Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '})
$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 =~ s' . $ldel . '\A(?:' . $self->{"pattern"} . ')'
. $rdel . $sdel . $mod . ')
'.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>},
Parse::RecDescent::_tracefirst($text))
Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
Parse
::RecDescent
::_tracefirst
($text))
push @item, $item{'.$self->{hashname}.'}=$&;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
package Parse::RecDescent::Literal;
sub sethashname { $_[0]->{hashname} = '__STRING
' . ++$_[1]->{strcount} . '__
'; }
sub describe ($) { shift->{'description
'} }
my $class = ref($_[0]) || $_[0];
"description" => "'$desc'",
my ($self, $namespace, $rule, $check) = @_;
Parse
::RecDescent
::_trace
(q{Trying terminal: [' . $self->describe
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '})
$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 =~ s/\A' . quotemeta($self->{"pattern"}) . '//)
'.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
Parse::RecDescent::_trace(qq{<<Didn\'t match terminal>>},
Parse::RecDescent::_tracefirst($text))
Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
Parse
::RecDescent
::_tracefirst
($text))
push @item, $item{'.$self->{hashname}.'}=$&;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
package Parse::RecDescent::InterpLit;
sub sethashname { $_[0]->{hashname} = '__STRING
' . ++$_[1]->{strcount} . '__
'; }
sub describe ($) { shift->{'description
'} }
my $class = ref($_[0]) || $_[0];
"description" => "'$desc'",
my ($self, $namespace, $rule, $check) = @_;
Parse
::RecDescent
::_trace
(q{Trying terminal: [' . $self->describe
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{name} . '})
$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;' : '').'
Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>},
Parse::RecDescent::_tracefirst($text))
Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
Parse
::RecDescent
::_tracefirst
($text))
push @item, $item{'.$self->{hashname}.'}=$_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
package Parse::RecDescent::Subrule;
sub issubrule ($) { return $_[0]->{"subrule"} }
my $desc = $_[0]->{"implicit"} || $_[0]->{"subrule"};
$desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
if ($_[0]->{"matchrule"})
return "&{'$_[1]'.qq{$_[0]->{subrule}}}";
return $_[1].$_[0]->{"subrule"};
my $class = ref($_[0]) || $_[0];
"implicit" => $_[4] || undef,
"argcode" => $_[6] || undef,
my ($self, $namespace, $rule) = @_;
Parse
::RecDescent
::_trace
(q{Trying subrule: [' . $self->{"subrule"} . ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} . '})
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')
. $self->callsyntax($namespace.'::')
. '($thisparser,$text,$repeating,'
. ($self->{"lookahead"}?
'1':'$_noactions')
. ($self->{argcode
} ?
",sub { return $self->{argcode} }"
'.($self->{"lookahead"} ?
'$text = $_savetext;' : '').'
Parse::RecDescent::_trace(q{<<Didn\'t match subrule: ['
. $self->{subrule
} . ']>>},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'})
Parse::RecDescent::_trace(q{>>Matched subrule: ['
. $self->{subrule
} . ']<< (return value: [}
Parse
::RecDescent
::_tracefirst
($text),
q{' . $rule->{"name"} .'})
$item{q{' . $self->{subrule} . '}} = $_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
package Parse::RecDescent::Repetition;
sub issubrule ($) { return $_[0]->{"subrule"} }
my $desc = $_[0]->{"expected"} || $_[0]->{"subrule"};
$desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
{ return "sub { goto &{''.qq{$_[1]$_[0]->{subrule}}} }"; }
{ return "\\&$_[1]$_[0]->{subrule}"; }
my ($self, $subrule, $repspec, $min, $max, $lookahead, $line, $parser, $matchrule, $argcode) = @_;
my $class = ref($self) || $self;
($max, $min) = ( $min, $max) if ($max<$min);
if ($subrule=~/\A_alternation_\d+_of_production_\d+_of_rule/)
{ $desc = $parser->{"rules"}{$subrule}->expected }
return new Parse::RecDescent::Subrule($subrule,$lookahead,$line,$desc,$matchrule,$argcode);
Parse::RecDescent::_error("Not symbol (\"!\") before
\"$subrule\" doesn't make
Parse::RecDescent::_hint("Lookahead for negated optional
\"!$subrule($repspec)\" can never
succeed, since optional items always
match (zero times at worst).
Did you mean a single \"!$subrule\",
"lookahead" => $lookahead,
"argcode" => $argcode || undef,
"matchrule" => $matchrule,
my ($self, $namespace, $rule) = @_;
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"} . '})
$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')
. ($self->{argcode
} ?
"sub { return $self->{argcode} }"
Parse::RecDescent::_trace(q{<<Didn\'t match repeated subrule: ['
. $self->describe . ']>>},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'})
Parse::RecDescent::_trace(q{>>Matched repeated subrule: ['
. $self->{subrule
} . ']<< (}
Parse
::RecDescent
::_tracefirst
($text),
q{' . $rule->{"name"} .'})
$item{q{' . $self->describe . '}} = $_tok;
' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
package Parse::RecDescent::Result;
my ($self, $namespace, $rule) = @_;
package Parse::RecDescent::Operator;
my @opertype = ( " non-optional", "n optional" );
sub describe { $_[0]->{"expected"} }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; }
my ($class, $type, $minrep, $maxrep, $leftarg, $op, $rightarg) = @_;
"expected" => "<${type}op: ".$leftarg->describe." ".$op->describe." ".$rightarg->describe.">",
my ($self, $namespace, $rule) = @_;
my ($leftarg, $op, $rightarg) =
@{$self}{ qw{leftarg op rightarg} };
Parse::RecDescent::_trace(q{Trying operator: [' . $self->describe . ']},
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} . '})
$expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
# WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
: 'q{'.$self->describe.'}' ) . ')->at($text);
if ($self->{type
} eq "leftop" )
' . $leftarg->code(@_[1..2]) . '
while ($repcount < ' . $self->{max
} . ')
' . $op->code(@_[1..2]) . '
' . ($op->isterminal() ?
'pop @item;' : '$backtrack=1;' ) . '
' . (ref($op) eq 'Parse::RecDescent::Token'
?
'if (defined $1) {push @item, $item{'.$self->{hashname
}.'}=$1; $backtrack=1;}'
' . $rightarg->code(@_[1..2]) . '
while ($repcount < ' . $self->{max
} . ')
' . $leftarg->code(@_[1..2]) . '
' . $op->code(@_[1..2]) . '
' . ($op->isterminal() ?
'pop @item;' : "" ) . '
' . (ref($op) eq 'Parse::RecDescent::Token' ?
'do { push @item, $item{'.$self->{hashname
}.'}=$1; } if defined $1;' : "" ) . '
' . $rightarg->code(@_[1..2]) . '
$code .= 'unless (@item) { undef $_tok; last }' unless $self->{min
}==0;
unless ($repcount>='.$self->{min
}.')
Parse::RecDescent::_trace(q{<<Didn\'t match operator: ['
Parse::RecDescent::_tracefirst($text),
q{' . $rule->{"name"} .'})
Parse::RecDescent::_trace(q{>>Matched operator: ['
. qq{@{$_tok||[]}} . q{]},
Parse
::RecDescent
::_tracefirst
($text),
q{' . $rule->{"name"} .'})
push @item, $item{'.$self->{hashname}.'}=$_tok||[];
package Parse::RecDescent::Expectation;
$_[0]->{lastexpected} = $_[1]; return $_[0];
$_[0]->{lastunexpected} = $_[1]; return $_[0];
return unless $_[0]->{lastexpected};
$_[0]->{expected} = $_[0]->{lastexpected} unless $_[0]->{failed};
$_[0]->{unexpected} = $_[0]->{lastunexpected} unless $_[0]->{failed};
$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}";
$self->{unexpected} =~ /\s*(.*)/;
return "Was expecting $self->{expected} but found \"$1\" instead";
package Parse::RecDescent;
use vars qw ( $AUTOLOAD $VERSION );
my $nextnamespace = "namespace000001";
return "Parse::RecDescent::" . $nextnamespace++;
my $class = ref($_[0]) || $_[0];
local $Parse::RecDescent::compiling = $_[2],
"namespace" => _nextnamespace(),
my $sourcecode = $::RD_AUTOACTION;
$sourcecode = "{ $sourcecode }"
unless $sourcecode =~ /\A\s*\{.*\}\s*\Z/;
= new Parse::RecDescent::Action($sourcecode,0,-1)
return $self->Replace(@_)
die "Compilation of Parse::RecDescent grammars not yet implemented\n";
sub DESTROY {} # SO AUTOLOADER IGNORES IT
_error("Ruleless $_[0] at start of grammar.",$_[1]);
my $desc = $_[2] ? "\"$_[2]\"" : "";
_hint("You need to define a rule for the $_[0] $desc
my $NEGLOOKAHEAD = '\G(\s*\.\.\.\!)';
my $POSLOOKAHEAD = '\G(\s*\.\.\.)';
my $RULE = '\G\s*(\w+)[ \t]*:';
my $TOKEN = q{\G\s*/((\\\\/|[^/])*)/([cgimsox]*)};
my $MTOKEN = q{\G\s*(m\s*[^\w\s])};
my $LITERAL = q{\G\s*'((\\\\['\\\\]|[^'])*)'};
my $INTERPLIT = q{\G\s*"((\\\\["\\\\]|[^"])*)"};
my $SUBRULE = '\G\s*(\w+)';
my $MATCHRULE = '\G(\s*<matchrule:)';
my $SIMPLEPAT = '((\\s+\\/[^\\/\\\\]*(?:\\\\\\/[^\\/\\\\]*)*\\/)?)';
my $OPTIONAL = '\G\((\?)'.$SIMPLEPAT.'\)';
my $ANY = '\G\((s\?)'.$SIMPLEPAT.'\)';
my $MANY = '\G\((s|\.\.)'.$SIMPLEPAT.'\)';
my $EXACTLY = '\G\(([1-9]\d*)'.$SIMPLEPAT.'\)';
my $BETWEEN = '\G\((\d+)\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
my $ATLEAST = '\G\((\d+)\.\.'.$SIMPLEPAT.'\)';
my $ATMOST = '\G\(\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
my $BADREP = '\G\((-?\d+)?\.\.(-?\d+)?'.$SIMPLEPAT.'\)';
my $IMPLICITSUBRULE = '\G\s*\(';
my $COMMENT = '\G\s*(#.*)';
my $COMMITMK = '\G\s*<commit>';
my $UNCOMMITMK = '\G\s*<uncommit>';
my $QUOTELIKEMK = '\G\s*<perl_quotelike>';
my $CODEBLOCKMK = '\G\s*<perl_codeblock>';
my $VARIABLEMK = '\G\s*<perl_variable>';
my $NOCHECKMK = '\G\s*<nocheck>';
my $AUTOTREEMK = '\G\s*<autotree>';
my $AUTOSTUBMK = '\G\s*<autostub>';
my $REJECTMK = '\G\s*<reject>';
my $CONDREJECTMK = '\G\s*<reject:';
my $SCOREMK = '\G\s*<score:';
my $AUTOSCOREMK = '\G\s*<autoscore:';
my $SKIPMK = '\G\s*<skip:';
my $OPMK = '\G\s*<(left|right)op:';
my $ENDDIRECTIVEMK = '\G\s*>';
my $RESYNCMK = '\G\s*<resync>';
my $RESYNCPATMK = '\G\s*<resync:';
my $RULEVARPATMK = '\G\s*<rulevar:';
my $DEFERPATMK = '\G\s*<defer:';
my $TOKENPATMK = '\G\s*<token:';
my $AUTOERRORMK = '\G\s*<error(\??)>';
my $MSGERRORMK = '\G\s*<error(\??):';
my $UNCOMMITPROD = $PROD.'\s*<uncommit';
my $ERRORPROD = $PROD.'\s*<error';
my $LONECOLON = '\G\s*:';
my $OTHER = '\G\s*([^\s]+)';
my ($self, $grammar, $replace, $isimplicit, $isleftop) = (@_, 0);
$lines = _linecount($grammar) unless $lines;
$self->{_check}{itempos} = ($grammar =~ /\@itempos\b|\$itempos\s*\[/)
unless $self->{_check}{itempos};
for (qw(thisoffset thiscolumn prevline prevoffset prevcolumn))
($grammar =~ /\$$_/) || $self->{_check
}{itempos
}
unless $self->{_check
}{$_};
while (pos $grammar < length $grammar)
$line = $lines - _linecount
($grammar) + 1;
if ($grammar =~ m/$COMMENT/gco)
_parse
("a comment",0,$line);
elsif ($grammar =~ m/$NEGLOOKAHEAD/gco)
_parse
("a negative lookahead",$aftererror,$line);
$lookahead = $lookahead ?
-$lookahead : -1;
next; # SKIP LOOKAHEAD RESET AT END OF while LOOP
elsif ($grammar =~ m/$POSLOOKAHEAD/gco)
_parse
("a positive lookahead",$aftererror,$line);
$lookahead = $lookahead ?
$lookahead : 1;
next; # SKIP LOOKAHEAD RESET AT END OF while LOOP
elsif ($grammar =~ m/(?=$ACTION)/gco
and do { ($code) = extract_codeblock
($grammar); $code })
_parse
("an action", $aftererror, $line, $code);
$item = new Parse
::RecDescent
::Action
($code,$lookahead,$line);
$prod and $prod->additem($item)
or $self->_addstartcode($code);
elsif ($grammar =~ m/(?=$IMPLICITSUBRULE)/gco
and do { ($code) = extract_codeblock
($grammar,'{([',undef,'(',1);
$code =~ s/\A\s*\(|\)\Z//g;
_parse
("an implicit subrule", $aftererror, $line,
my $implicit = $rule->nextimplicit;
$self->_generate("$implicit : $code",$replace,1);
substr($grammar,$pos,0,$implicit);
elsif ($grammar =~ m/$ENDDIRECTIVEMK/gco)
# EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)
my ($minrep,$maxrep) = (1,$MAXREP);
if ($grammar =~ m/\G[(]/gc)
if ($grammar =~ m/$OPTIONAL/gco)
{ ($minrep, $maxrep) = (0,1) }
elsif ($grammar =~ m/$ANY/gco)
elsif ($grammar =~ m/$EXACTLY/gco)
{ ($minrep, $maxrep) = ($1,$1) }
elsif ($grammar =~ m/$BETWEEN/gco)
{ ($minrep, $maxrep) = ($1,$2) }
elsif ($grammar =~ m/$ATLEAST/gco)
elsif ($grammar =~ m/$ATMOST/gco)
elsif ($grammar =~ m/$MANY/gco)
elsif ($grammar =~ m/$BADREP/gco)
_parse
("an invalid repetition specifier", 0,$line);
_error
("Incorrect specification of a repeated directive",
_hint
("Repeated directives cannot have
a maximum repetition of zero, nor can they have
negative components in their ranges.");
$prod && $prod->enddirective($line,$minrep,$maxrep);
elsif ($grammar =~ m/\G\s*<[^m]/gc)
if ($grammar =~ m/$OPMK/gco)
_parse
("a $1-associative operator directive", $aftererror, $line, "<$1op:...>");
$prod->adddirective($1, $line);
elsif ($grammar =~ m/$UNCOMMITMK/gco)
_parse
("an uncommit marker", $aftererror,$line);
$item = new Parse
::RecDescent
::Directive
('$commit=0;1',
$lookahead,$line,"<uncommit>");
$prod and $prod->additem($item)
or _no_rule
("<uncommit>",$line);
elsif ($grammar =~ m/$QUOTELIKEMK/gco)
_parse
("an perl quotelike marker", $aftererror,$line);
$item = new Parse
::RecDescent
::Directive
(
($match,$text,undef,@res) =
Text::Balanced::extract_quotelike($text,$skip);
', $lookahead,$line,"<perl_quotelike>");
$prod and $prod->additem($item)
or _no_rule
("<perl_quotelike>",$line);
elsif ($grammar =~ m/$CODEBLOCKMK/gco)
_parse
("an perl codeblock marker", $aftererror,$line);
$item = new Parse
::RecDescent
::Directive
(
'Text::Balanced::extract_codeblock($text,undef,$skip);
', $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);
$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);
_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
elsif ($grammar =~ m/$AUTOSTUBMK/gco)
_parse
("an autostub marker", $aftererror,$line);
elsif ($grammar =~ m/$AUTOTREEMK/gco)
_parse
("an autotree marker", $aftererror,$line);
_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
undef $self->{_AUTOACTION
};
= new Parse
::RecDescent
::Action
(q{{bless \%item, $item[0]}},0,-1);
$self->{_AUTOTREE}{TERMINAL}
= new Parse::RecDescent::Action(q{{bless {__VALUE__=>$item[1]}, $item[0]}},0,-1);
elsif ($grammar =~ m/$REJECTMK/gco)
_parse("an reject marker", $aftererror,$line);
$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,'<');
_parse("a (conditional) reject marker", $aftererror,$line);
$code =~ /\A\s*<reject:(.*)>\Z/s;
$item = new Parse::RecDescent::Directive(
"($1) ? undef : 1", $lookahead,$line,"<reject:$code>");
$prod and $prod->additem($item)
or _no_rule("<reject:$code>",$line);
elsif ($grammar =~ m/(?=$SCOREMK)/gco
and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
_parse("a score marker", $aftererror,$line);
$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,'<');
_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);
$item = new Parse::RecDescent::Directive(
'if ($text =~ s/\A[^\n]*\n//) { $return = 0; $& } 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,'<');
_parse("a resync with pattern marker", $aftererror,$line);
$code =~ /\A\s*<resync:(.*)>\Z/s;
$item = new Parse::RecDescent::Directive(
'if ($text =~ s/\A'.$1.'//) { $return = 0; $& } else { undef }',
$prod and $prod->additem($item)
or _no_rule($code,$line);
elsif ($grammar =~ m/(?=$SKIPMK)/gco
and do { ($code) = extract_codeblock($grammar,'<');
_parse("a skip marker", $aftererror,$line);
$code =~ /\A\s*<skip:(.*)>\Z/s;
$item = new Parse::RecDescent::Directive(
'my $oldskip = $skip; $skip='.$1.'; $oldskip',
$prod and $prod->additem($item)
or _no_rule($code,$line);
elsif ($grammar =~ m/(?=$RULEVARPATMK)/gco
and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
_parse("a rule variable specifier", $aftererror,$line,$code);
$code =~ /\A\s*<rulevar:(.*)>\Z/s;
$rule and $rule->addvar($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/(?=$DEFERPATMK)/gco
and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
_parse("a deferred action specifier", $aftererror,$line,$code);
$code =~ s/\A\s*<defer:(.*)>\Z/$1/s;
if ($code =~ /\A\s*[^{]|[^}]\s*\Z/)
$item = new Parse::RecDescent::Directive(
"push \@{\$thisparser->{deferred}}, sub $code;",
$lookahead,$line,"<defer:$code>");
$prod and $prod->additem($item)
or _no_rule("<defer:$code>",$line);
elsif ($grammar =~ m/(?=$TOKENPATMK)/gco
and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
_parse("a token constructor", $aftererror,$line,$code);
$code =~ s/\A\s*<token:(.*)>\Z/$1/s;
my $types = eval 'no strict; local $SIG{__WARN__} = sub {0}; my @arr=('.$code.'); @arr' || ();
_error("Incorrect token specification: \"$@\"", $line);
_hint("The <token:...> directive requires a list
of one or more strings representing possible
types of the specified token. For example:
$item = new Parse::RecDescent::Directive(
$return = { text => $item[-1] };
@{$return->{type}}{'.$code.'} = (1..'.$types.');',
$lookahead,$line,"<token:$code>");
$prod and $prod->additem($item)
or _no_rule("<token:$code>",$line);
elsif ($grammar =~ m/$COMMITMK/gco)
_parse("an commit marker", $aftererror,$line);
$item = new Parse::RecDescent::Directive('$commit = 1',
$lookahead,$line,"<commit>");
$prod and $prod->additem($item)
or _no_rule("<commit>",$line);
elsif ($grammar =~ m/$AUTOERRORMK/gco)
_parse("an error marker", $aftererror,$line);
$item = new Parse::RecDescent::Error('',$lookahead,$1,$line);
$prod and $prod->additem($item)
or _no_rule("<error>",$line);
$aftererror = !$commitonly;
elsif ($grammar =~ m/(?=$MSGERRORMK)/gco
and do { $commitonly = $1;
($code) = extract_bracketed($grammar,'<');
_parse("an error marker", $aftererror,$line,$code);
$code =~ /\A\s*<error\??:(.*)>\Z/s;
$item = new Parse::RecDescent::Error($1,$lookahead,$commitonly,$line);
$prod and $prod->additem($item)
or _no_rule("$code",$line);
$aftererror = !$commitonly;
elsif (do { $commitonly = $1;
($code) = extract_bracketed($grammar,'<');
if ($code =~ /^<[A-Z_]+>$/)
_error("Token items are not yet
_hint("Items like $code that consist of angle
brackets enclosing a sequence of
uppercase characters will eventually
be used to specify pre-lexed tokens
in a grammar. That functionality is not
yet implemented. Or did you misspell
_error("Untranslatable item encountered: \"$code\"",
_hint("Did you misspell \"$code\"
or forget to comment it out?");
elsif ($grammar =~ m/$RULE/gco)
_parseunneg("a rule declaration", 0,
$lookahead,$line) or next;
if ($rulename =~ /Replace|Extend|Precompile|Save/ )
_warn(2,"Rule \"$rulename\" hidden by method
Parse::RecDescent::$rulename",$line)
_hint("The rule named \"$rulename\" cannot be directly
called through the Parse::RecDescent object
for this grammar (although it may still
be used as a subrule of other rules).
It can't be directly called because
Parse::RecDescent::$rulename is already defined (it
is the standard method of all
$rule = new Parse::RecDescent::Rule($rulename,$self,$line,$replace);
$prod->check_pending($line) if $prod;
$prod = $rule->addprod( new Parse::RecDescent::Production );
elsif ($grammar =~ m/$UNCOMMITPROD/gco)
_parseunneg("a new (uncommitted) production",
0, $lookahead, $line) or next;
$prod->check_pending($line) if $prod;
$prod = new Parse::RecDescent::Production($line,1,0);
$rule and $rule->addprod($prod)
or _no_rule("<uncommit>",$line);
elsif ($grammar =~ m/$ERRORPROD/gco)
_parseunneg("a new (error) production", $aftererror,
$lookahead,$line) or next;
$prod->check_pending($line) if $prod;
$prod = new Parse::RecDescent::Production($line,0,1);
$rule and $rule->addprod($prod)
or _no_rule("<error>",$line);
elsif ($grammar =~ m/$PROD/gco)
_parseunneg("a new production", 0,
$lookahead,$line) or next;
and (!$prod || $prod->check_pending($line))
and $prod = $rule->addprod(new Parse::RecDescent::Production($line))
or _no_rule("production",$line);
elsif ($grammar =~ m/$LITERAL/gco)
($code = $1) =~ s/\\\\/\\/g;
_parse("a literal terminal", $aftererror,$line,$1);
$item = new Parse::RecDescent::Literal($code,$lookahead,$line);
$prod and $prod->additem($item)
or _no_rule("literal terminal",$line,"'$1'");
elsif ($grammar =~ m/$INTERPLIT/gco)
_parse("an interpolated literal terminal", $aftererror,$line);
$item = new Parse::RecDescent::InterpLit($1,$lookahead,$line);
$prod and $prod->additem($item)
or _no_rule("interpolated literal terminal",$line,"'$1'");
elsif ($grammar =~ m/$TOKEN/gco)
_parse("a /../ pattern terminal", $aftererror,$line);
$item = new Parse::RecDescent::Token($1,'/',$3?$3:'',$lookahead,$line);
$prod and $prod->additem($item)
or _no_rule("pattern terminal",$line,"/$1/");
elsif ($grammar =~ m/(?=$MTOKEN)/gco
and do { ($code, undef, @components)
= extract_quotelike($grammar);
_parse("an m/../ pattern terminal", $aftererror,$line,$code);
$item = new Parse::RecDescent::Token(@components[3,2,8],
$prod and $prod->additem($item)
or _no_rule("pattern terminal",$line,$code);
elsif ($grammar =~ m/(?=$MATCHRULE)/gco
and do { ($code) = extract_bracketed($grammar,'<');
or $grammar =~ m/$SUBRULE/gco
if (substr($name,0,1) eq '<')
$name =~ s/$MATCHRULE\s*//;
# EXTRACT TRAILING ARG LIST (IF ANY)
my ($argcode) = extract_codeblock($grammar, "[]",'') || '';
# EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)
if ($grammar =~ m/\G[(]/gc)
if ($grammar =~ m/$OPTIONAL/gco)
_parse("an zero-or-one subrule match", $aftererror,$line,"$code$argcode($1)");
$item = new Parse::RecDescent::Repetition($name,$1,0,1,
$prod and $prod->additem($item)
or _no_rule("repetition",$line,"$code$argcode($1)");
!$matchrule and $rule and $rule->addcall($name);
elsif ($grammar =~ m/$ANY/gco)
_parse("a zero-or-more subrule match", $aftererror,$line,"$code$argcode($1)");
"<leftop: $name $2 $name>(s?) ");
$item = new Parse::RecDescent::Repetition($name,$1,0,$MAXREP,
$prod and $prod->additem($item)
or _no_rule("repetition",$line,"$code$argcode($1)");
!$matchrule and $rule and $rule->addcall($name);
_check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK;
elsif ($grammar =~ m/$MANY/gco)
_parse("a one-or-more subrule match", $aftererror,$line,"$code$argcode($1)");
"<leftop: $name $2 $name> ");
$item = new Parse::RecDescent::Repetition($name,$1,1,$MAXREP,
$prod and $prod->additem($item)
or _no_rule("repetition",$line,"$code$argcode($1)");
!$matchrule and $rule and $rule->addcall($name);
_check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK;
elsif ($grammar =~ m/$EXACTLY/gco)
_parse("an exactly-$1-times subrule match", $aftererror,$line,"$code$argcode($1)");
"<leftop: $name $2 $name>($1) ");
$item = new Parse::RecDescent::Repetition($name,$1,$1,$1,
$prod and $prod->additem($item)
or _no_rule("repetition",$line,"$code$argcode($1)");
!$matchrule and $rule and $rule->addcall($name);
elsif ($grammar =~ m/$BETWEEN/gco)
_parse("a $1-to-$2 subrule match", $aftererror,$line,"$code$argcode($1..$2)");
"<leftop: $name $3 $name>($1..$2) ");
$item = new Parse::RecDescent::Repetition($name,"$1..$2",$1,$2,
$prod and $prod->additem($item)
or _no_rule("repetition",$line,"$code$argcode($1..$2)");
!$matchrule and $rule and $rule->addcall($name);
elsif ($grammar =~ m/$ATLEAST/gco)
_parse("a $1-or-more subrule match", $aftererror,$line,"$code$argcode($1..)");
"<leftop: $name $2 $name>($1..) ");
$item = new Parse::RecDescent::Repetition($name,"$1..",$1,$MAXREP,
$prod and $prod->additem($item)
or _no_rule("repetition",$line,"$code$argcode($1..)");
!$matchrule and $rule and $rule->addcall($name);
_check_insatiable($name,"$1..",$grammar,$line) if $::RD_CHECK;
elsif ($grammar =~ m/$ATMOST/gco)
_parse("a one-to-$1 subrule match", $aftererror,$line,"$code$argcode(..$1)");
"<leftop: $name $2 $name>(..$1) ");
$item = new Parse::RecDescent::Repetition($name,"..$1",1,$1,
$prod and $prod->additem($item)
or _no_rule("repetition",$line,"$code$argcode(..$1)");
!$matchrule and $rule and $rule->addcall($name);
elsif ($grammar =~ m/$BADREP/gco)
_parse("an subrule match with invalid repetition specifier", 0,$line);
_error("Incorrect specification of a repeated subrule",
_hint("Repeated subrules like \"$code$argcode$&\" cannot have
a maximum repetition of zero, nor can they have
negative components in their ranges.");
_parse("a subrule match", $aftererror,$line,$code);
if ($name=~/\A_alternation_\d+_of_production_\d+_of_rule/)
{ $desc = $self->{"rules"}{$name}->expected }
$item = new Parse::RecDescent::Subrule($name,
$prod and $prod->additem($item)
or _no_rule("(sub)rule",$line,$name);
!$matchrule and $rule and $rule->addcall($name);
elsif ($grammar =~ m/$LONECOLON/gco )
_error("Unexpected colon encountered", $line);
_hint("Did you mean \"|\" (to start a new production)?
Or perhaps you forgot that the colon
in a rule definition must be
on the same line as the rule name?");
elsif ($grammar =~ m/$ACTION/gco ) # BAD ACTION, ALREADY FAILED
_error("Malformed action encountered",
_hint("Did you forget the closing curly bracket
or is there a syntax error in the action?");
elsif ($grammar =~ m/$OTHER/gco )
_error("Untranslatable item encountered: \"$1\"",
_hint("Did you misspell \"$1\"
or forget to comment it out?");
if ($lookaheadspec =~ tr /././ > 3)
$lookaheadspec =~ s/\A\s+//;
$lookahead = $lookahead<0
? 'a negative lookahead ("...!")'
: 'a positive lookahead ("...")' ;
_warn(1,"Found two or more lookahead specifiers in a
_hint("Multiple positive and/or negative lookaheads
are simply multiplied together to produce a
single positive or negative lookahead
specification. In this case the sequence
\"$lookaheadspec\" was reduced to $lookahead.
Was this your intention?");
unless ($ERRORS or $isimplicit or !$::RD_CHECK)
unless ($ERRORS or $isimplicit or $Parse::RecDescent::compiling)
my $code = $self->_code();
print STDERR "printing code (", length($code),") to RD_TRACE\n";
open TRACE_FILE, ">RD_TRACE"
and print TRACE_FILE "my \$ERRORS;\n$code"
unless ( eval "$code 1" )
_error("Internal error in generated parser code!");
$@ =~ s/at grammar/in grammar at/;
if ($ERRORS and !_verbosity("HINT"))
_hint('Set $::RD_HINT (or -RD_HINT if you\'re using "perl -s")
for hints on fixing these problems.');
if ($ERRORS) { $ERRORS=0; return }
$code =~ s/\A\s*\{(.*)\}\Z/$1/s;
$self->{"startcode"} .= "$code;\n";
# CHECK FOR GRAMMAR PROBLEMS....
sub _check_insatiable($$$$)
my ($subrule,$repspec,$grammar,$line) = @_;
pos($grammar)=pos($_[2]);
return if $grammar =~ m/$OPTIONAL/gco || $grammar =~ m/$ANY/gco;
if ( $grammar =~ m/$MANY/gco
|| $grammar =~ m/$EXACTLY/gco
|| $grammar =~ m/$ATMOST/gco
|| $grammar =~ m/$BETWEEN/gco && do { $min=$2; 1 }
|| $grammar =~ m/$ATLEAST/gco && do { $min=$2; 1 }
|| $grammar =~ m/$SUBRULE(?!\s*:)/gco
return unless $1 eq $subrule && $min > 0;
_warn(3,"Subrule sequence \"$subrule($repspec) $&\" will
(almost certainly) fail.",$line)
_hint("Unless subrule \"$subrule\" performs some cunning
lookahead, the repetition \"$subrule($repspec)\" will
insatiably consume as many matches of \"$subrule\" as it
can, leaving none to match the \"$&\" that follows.");
my $rules = $self->{"rules"};
foreach $rule ( values %$rules )
next if ! $rule->{"changed"};
# CHECK FOR UNDEFINED RULES
foreach $call ( @{$rule->{"calls"}} )
if (!defined ${$rules}{$call}
&&!defined &{"Parse::RecDescent::$call"})
if (!defined $::RD_AUTOSTUB)
_warn(3,"Undefined (sub)rule \"$call\"
_hint("Will you be providing this rule
later, or did you perhaps
misspell \"$call\"? Otherwise
eval "sub $self->{namespace}::$call {undef}";
_warn(1,"Autogenerating rule: $call")
_hint("A call was made to a subrule
named \"$call\", but no such
rule was specified. However,
automatically created.");
$self->_generate("$call : '$call'",0,1);
# CHECK FOR LEFT RECURSION
if ($rule->isleftrec($rules))
_error("Rule \"$rule->{name}\" is left-recursive.");
_hint("Redesign the grammar so it's not left-recursive.
That will probably mean you need to re-implement
repetitions using the '(s)' notation.
For example: \"$rule->{name}(s)\".");
# GENERATE ACTUAL PARSER CODE
package $self->{namespace};
use vars qw(\$skip \$AUTOLOAD $self->{localvars} );
local \$SIG{__WARN__} = sub {0};
# PRETEND TO BE IN Parse::RecDescent NAMESPACE
*$self->{namespace}::AUTOLOAD = sub
\$AUTOLOAD =~ s/^$self->{namespace}/Parse::RecDescent/;
$code .= "push \@$self->{namespace}\::ISA, 'Parse::RecDescent';";
$self->{"startcode"} = '';
foreach $rule ( values %{$self->{"rules"}} )
$code .= $rule->code($self->{"namespace"},$self);
sub AUTOLOAD # ($parser, $text; $linenum, @args)
croak "Could not find method: $AUTOLOAD\n" unless ref $_[0];
my $class = ref($_[0]) || $_[0];
my $text = ref($_[1]) ? ${$_[1]} : $_[1];
$_[0]->{lastlinenum} = $_[2]||_linecount($_[1]);
$_[0]->{offsetlinenum} = $_[0]->{lastlinenum};
$_[0]->{fulltext} = $text;
$_[0]->{fulltextlen} = length $text;
my $args = sub { [ @args ] };
$AUTOLOAD =~ s/$class/$_[0]->{namespace}/;
croak "Unknown starting rule ($AUTOLOAD) called\n"
unless defined &$AUTOLOAD;
my $retval = &{$AUTOLOAD}($_[0],$text,undef,undef,$args);
foreach ( @{$_[0]->{deferred}} ) { &$_; }
foreach ( @{$_[0]->{errors}} ) { _error(@$_); }
if (ref $_[1]) { ${$_[1]} = $text }
sub _parserepeat($$$$$$$$$$) # RETURNS A REF TO AN ARRAY OF MATCHES
my ($parser, $text, $prod, $min, $max, $_noactions, $expectation, $argcode) = @_;
for ($reps=0; $reps<$max;)
$_[6]->at($text); # $_[6] IS $expectation FROM CALLER
my $prevtextlen = length $text;
if (! defined ($_tok = &$prod($parser,$text,1,$_noactions,$argcode)))
push @tokens, $_tok if defined $_tok;
last if ++$reps >= $min and $prevtextlen == length $text;
do { $_[6]->failed(); return undef} if $reps<$min;
open (ERROR, ">&STDERR");
@>>>>>>>>>>>>>>>>>>>>: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
open (TRACE, ">&STDERR");
|@|||||||||@^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
$tracerulename, '|', $tracemsg
| ~~ |^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
open (TRACECONTEXT, ">&STDERR");
|@|||||||||@ |^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$tracerulename, '|', $tracecontext
| ~~ | |^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
or defined $::RD_HINT and $_[0] =~ /ERRORS|WARN|HINT/
or defined $::RD_WARN and $_[0] =~ /ERRORS|WARN/
or defined $::RD_ERRORS and $_[0] =~ /ERRORS/
return 0 if ! _verbosity("ERRORS");
$errorprefix = "ERROR" . ($_[1] ? " (line $_[1])" : "");
print ERROR "\n" if _verbosity("WARN");
return 0 unless _verbosity("WARN") && ($::RD_HINT || $_[0] >= ($::RD_WARN||1));
$errorprefix = "Warning" . ($_[2] ? " (line $_[2])" : "");
return 0 unless defined $::RD_HINT;
&& $::RD_TRACE+10<length($_[0]))
my $count = length($_[0]) - $::RD_TRACE;
return substr($_[0],0,$::RD_TRACE/2)
. substr($_[0],-$::RD_TRACE/2);
&& $::RD_TRACE+10<length($_[0]))
my $count = length($_[0]) - $::RD_TRACE;
return substr($_[0],0,$::RD_TRACE) . "...<+$count>";
$tracecontext = $_[1]||$lastcontext;
$tracerulename = $_[2]||$lastrulename;
if ($tracerulename) { $lastrulename = $tracerulename }
$tracecontext =~ s/\n/\\n/g;
$tracecontext =~ s/\s+/ /g;
$tracerulename = qq{$tracerulename};
if ($tracecontext ne $lastcontext)
$lastcontext = $tracecontext;
$tracecontext = qq{"$tracecontext"};
$tracecontext = qq{<NO TEXT LEFT>};
_parse($_[0],$_[1],$_[3]);
_error("Can't negate \"$&\".",$_[3]);
_hint("You can't negate $_[0]. Remove the \"...!\" before
_warn(3,"Found $_[0] ($what) after an unconditional <error>",$_[2])
_hint("An unconditional <error> always causes the
production containing it to immediately fail.
\u$_[0] that follows an <error>
will never be reached. Did you mean to use
return if ! _verbosity("TRACE");
$errortext = "Treating \"$what\" as $_[0]";
$errorprefix = "Parse::RecDescent";
my ($pos,$count) = ((pos $_[0]||0)-1, 0);
$count++ until ($pos=index($_[0],"\n",$pos+1))<0;
use vars qw ( $RD_ERRORS $RD_WARN $RD_HINT $RD_TRACE $RD_CHECK );