summaryrefslogtreecommitdiff
path: root/source4
diff options
context:
space:
mode:
authorAndrew Tridgell <tridge@samba.org>2003-11-22 01:40:24 +0000
committerAndrew Tridgell <tridge@samba.org>2003-11-22 01:40:24 +0000
commit3f2598abad168b6bdf679cdd25fe0064ad198236 (patch)
tree90c09911919867f2ba6a333012b4d41b4b855365 /source4
parent2ca65a99c77d6d119617c330ce521a6137d71e35 (diff)
downloadsamba-3f2598abad168b6bdf679cdd25fe0064ad198236.tar.gz
samba-3f2598abad168b6bdf679cdd25fe0064ad198236.tar.bz2
samba-3f2598abad168b6bdf679cdd25fe0064ad198236.zip
added Parse::RecDescent module into pidl to ensure we all use the same
version. This should fix the problems Richard was seeing. (This used to be commit 76c24a5cb09b096a9cb490f3bb42af0b9d0f5fa9)
Diffstat (limited to 'source4')
-rw-r--r--source4/build/pidl/Makefile2
-rw-r--r--source4/build/pidl/lib/Parse/RecDescent.pm3045
-rw-r--r--source4/build/pidl/lib/README11
-rwxr-xr-xsource4/build/pidl/pidl.pl1
4 files changed, 3058 insertions, 1 deletions
diff --git a/source4/build/pidl/Makefile b/source4/build/pidl/Makefile
index 2ddf28389b..fd0ac4f857 100644
--- a/source4/build/pidl/Makefile
+++ b/source4/build/pidl/Makefile
@@ -1,5 +1,5 @@
idl.pm: idl.gram
- perl -MParse::RecDescent - idl.gram idl
+ perl -Ilib -MParse::RecDescent - idl.gram idl
clean:
rm -f idl.pm
diff --git a/source4/build/pidl/lib/Parse/RecDescent.pm b/source4/build/pidl/lib/Parse/RecDescent.pm
new file mode 100644
index 0000000000..35b9e9d2ce
--- /dev/null
+++ b/source4/build/pidl/lib/Parse/RecDescent.pm
@@ -0,0 +1,3045 @@
+# GENERATE RECURSIVE DESCENT PARSER OBJECTS FROM A GRAMMARC
+# SEE RecDescent.pod FOR FULL DETAILS
+
+use 5.005;
+use strict;
+
+package Parse::RecDescent;
+
+use Text::Balanced qw ( extract_codeblock extract_bracketed extract_quotelike extract_delimited );
+
+use vars qw ( $skip );
+
+ *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>")
+ unless @ARGV == 2;
+
+ my ($sourcefile, $class) = @ARGV;
+
+ local *IN;
+ open IN, $sourcefile
+ or _die("Can't open grammar file '$sourcefile'");
+
+ my $grammar = join '', <IN>;
+
+ Parse::RecDescent->Precompile($grammar, $class, $sourcefile);
+ exit;
+ }
+}
+
+sub Save
+{
+ my ($self, $class) = @_;
+ $self->{saving} = 1;
+ $self->Precompile(undef,$class);
+ $self->{saving} = 0;
+}
+
+sub Precompile
+{
+ my ($self, $grammar, $class, $sourcefile) = @_;
+
+ $class =~ /^(\w+::)*\w+$/ or croak("Bad class name: $class");
+
+ my $modulefile = $class;
+ $modulefile =~ s/.*:://;
+ $modulefile .= ".pm";
+
+ open OUT, ">$modulefile"
+ 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;
+
+ # local $::RD_HINT = 1;
+ $self = Parse::RecDescent->new($grammar,1,$class)
+ || croak("Can't compile bad grammar")
+ if $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 "my ";
+
+ require Data::Dumper;
+ print OUT Data::Dumper->Dump([$self], [qw(self)]);
+
+ print OUT "}";
+
+ close OUT
+ or croak("Can't write to new module file '$modulefile'");
+}
+
+
+package Parse::RecDescent::LineCounter;
+
+
+sub TIESCALAR # ($classname, \$text, $thisparser, $prevflag)
+{
+ bless {
+ text => $_[1],
+ parser => $_[2],
+ prev => $_[3]?1:0,
+ }, $_[0];
+}
+
+my %counter_cache;
+
+sub FETCH
+{
+ my $parser = $_[0]->{parser};
+ my $from = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}
+;
+
+ unless (exists $counter_cache{$from}) {
+ $parser->{lastlinenum} = $parser->{offsetlinenum}
+ - Parse::RecDescent::_linecount(substr($parser->{fulltext},$from))
+ + 1;
+ $counter_cache{$from} = $parser->{lastlinenum};
+ }
+ return $counter_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"}} )
+ {
+ my $next = $prod->expected();
+ unless (! $next or _contains($next,@expected) )
+ {
+ push @expected, $next;
+ }
+ }
+
+ return join ', or ', @expected;
+}
+
+sub _contains($@)
+{
+ my $target = shift;
+ my $item;
+ foreach $item ( @_ ) { return 1 if $target eq $item; }
+ return 0;
+}
+
+sub addcall($$)
+{
+ my ( $self, $subrule ) = @_;
+ unless ( _contains($subrule, @{$self->{"calls"}}) )
+ {
+ push @{$self->{"calls"}}, $subrule;
+ }
+}
+
+sub addprod($$)
+{
+ my ( $self, $prod ) = @_;
+ push @{$self->{"prods"}}, $prod;
+ $self->{"changed"} = 1;
+ $self->{"impcount"} = 0;
+ $self->{"opcount"} = 0;
+ $prod->{"number"} = $#{$self->{"prods"}};
+ return $prod;
+}
+
+sub addvar
+{
+ my ( $self, $var, $parser ) = @_;
+ if ($var =~ /\A\s*local\s+([%@\$]\w+)/)
+ {
+ $parser->{localvars} .= " $1";
+ $self->{"vars"} .= "$var;\n" }
+ else
+ { $self->{"vars"} .= "my $var;\n" }
+ $self->{"changed"} = 1;
+ return 1;
+}
+
+sub addautoscore
+{
+ my ( $self, $code ) = @_;
+ $self->{"autoscore"} = $code;
+ $self->{"changed"} = 1;
+ return 1;
+}
+
+sub nextoperator($)
+{
+ my $self = shift;
+ my $prodcount = scalar @{$self->{"prods"}};
+ my $opcount = ++$self->{"opcount"};
+ return "_operator_${opcount}_of_production_${prodcount}_of_rule_$self->{name}";
+}
+
+sub nextimplicit($)
+{
+ my $self = shift;
+ my $prodcount = scalar @{$self->{"prods"}};
+ my $impcount = ++$self->{"impcount"};
+ return "_alternation_${impcount}_of_production_${prodcount}_of_rule_$self->{name}";
+}
+
+
+sub code
+{
+ my ($self, $namespace, $parser) = @_;
+
+eval 'undef &' . $namespace . '::' . $self->{"name"} unless $parser->{saving};
+
+ my $code =
+'
+# ARGS ARE: ($parser, $text; $repeating, $_noactions, \@args)
+sub ' . $namespace . '::' . $self->{"name"} . '
+{
+ my $thisparser = $_[0];
+ use vars q{$tracelevel};
+ local $tracelevel = ($tracelevel||0)+1;
+ $ERRORS = 0;
+ my $thisrule = $thisparser->{"rules"}{"' . $self->{"name"} . '"};
+
+ Parse::RecDescent::_trace(q{Trying rule: [' . $self->{"name"} . ']},
+ Parse::RecDescent::_tracefirst($_[1]),
+ q{' . $self->{"name"} . '},
+ $tracelevel)
+ if defined $::RD_TRACE;
+
+ ' . ($parser->{deferrable}
+ ? 'my $def_at = @{$thisparser->{deferred}};'
+ : '') .
+ '
+ my $err_at = @{$thisparser->{errors}};
+
+ my $score;
+ my $score_return;
+ my $_tok;
+ my $return = undef;
+ my $_matched=0;
+ my $commit=0;
+ my @item = ();
+ my %item = ();
+ my $repeating = defined($_[2]) && $_[2];
+ my $_noactions = defined($_[3]) && $_[3];
+ my @arg = defined $_[4] ? @{ &{$_[4]} } : ();
+ my %arg = ($#arg & 01) ? @arg : (@arg, undef);
+ my $text;
+ my $lastsep="";
+ my $expectation = new Parse::RecDescent::Expectation($thisrule->expected());
+ $expectation->at($_[1]);
+ '. ($parser->{_check}{thisoffset}?'
+ my $thisoffset;
+ tie $thisoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser;
+ ':'') . ($parser->{_check}{prevoffset}?'
+ my $prevoffset;
+ tie $prevoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser, 1;
+ ':'') . ($parser->{_check}{thiscolumn}?'
+ my $thiscolumn;
+ tie $thiscolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser;
+ ':'') . ($parser->{_check}{prevcolumn}?'
+ my $prevcolumn;
+ tie $prevcolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser, 1;
+ ':'') . ($parser->{_check}{prevline}?'
+ my $prevline;
+ tie $prevline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser, 1;
+ ':'') . '
+ my $thisline;
+ tie $thisline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser;
+
+ '. $self->{vars} .'
+';
+
+ my $prod;
+ 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}
+ ? ' splice
+ @{$thisparser->{deferred}}, $def_at unless $_matched;
+ '
+ : '';
+ }
+
+ $code .=
+'
+ 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"} .'},
+ $tracelevel)
+ if defined $::RD_TRACE;
+ return undef;
+ }
+ if (!defined($return) && defined($score))
+ {
+ Parse::RecDescent::_trace(q{>>Accepted scored production<<}, "",
+ 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{>>Matched 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 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}},
+ Parse::RecDescent::UncondReject->new(0,0,'<reject>');
+ }
+ elsif (@items==1 && ($items[0]->describe||"") =~ /<rulevar|<autoscore/)
+ {
+ # Do nothing
+ }
+ elsif (@items &&
+ ( 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"
+ : "";
+ my $advice = @items > 1
+ ? "However, there were also other (useless) items after the leading "
+ . $items[0]->describe
+ . ", 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");
+ return 0;
+ }
+ return 1;
+}
+
+sub changesskip($)
+{
+ my $item;
+ foreach $item (@{$_[0]->{"items"}})
+ {
+ if (ref($item) =~ /Parse::RecDescent::(Action|Directive)/)
+ {
+ return 1 if $item->{code} =~ /\$skip/;
+ }
+ }
+ return 0;
+}
+
+sub adddirective
+{
+ my ( $self, $whichop, $line, $name ) = @_;
+ push @{$self->{op}},
+ { type=>$whichop, line=>$line, name=>$name,
+ offset=> scalar(@{$self->{items}}) };
+}
+
+sub addscore
+{
+ my ( $self, $code, $lookahead, $line ) = @_;
+ $self->additem(Parse::RecDescent::Directive->new(
+ "local \$^W;
+ 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/;
+ return 1;
+}
+
+sub check_pending
+{
+ my ( $self, $line ) = @_;
+ if ($self->{op})
+ {
+ 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 '>'?");
+ }
+ }
+ return 1;
+}
+
+sub enddirective
+{
+ my ( $self, $line, $minrep, $maxrep ) = @_;
+ unless ($self->{op})
+ {
+ 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.");
+ return;
+ }
+ my $op = pop @{$self->{op}};
+ my $span = @{$self->{items}} - $op->{offset};
+ if ($op->{type} =~ /left|right/)
+ {
+ if ($span != 3)
+ {
+ 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>");
+ }
+ else
+ {
+ push @{$self->{items}},
+ Parse::RecDescent::Operator->new(
+ $op->{type}, $minrep, $maxrep, splice(@{$self->{"items"}}, -3));
+ $self->{items}[-1]->sethashname($self);
+ $self->{items}[-1]{name} = $op->{name};
+ }
+ }
+}
+
+sub prevwasreturn
+{
+ 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:
+ <return: list>");
+ return;
+ }
+ push @{$self->{items}},
+ Parse::RecDescent::Result->new();
+}
+
+sub additem
+{
+ my ( $self, $item ) = @_;
+ $item->sethashname($self);
+ push @{$self->{"items"}}, $item;
+ return $item;
+}
+
+
+sub preitempos
+{
+ return q
+ {
+ push @itempos, {'offset' => {'from'=>$thisoffset, 'to'=>undef},
+ 'line' => {'from'=>$thisline, 'to'=>undef},
+ 'column' => {'from'=>$thiscolumn, 'to'=>undef} };
+ }
+}
+
+sub incitempos
+{
+ return q
+ {
+ $itempos[$#itempos]{'offset'}{'from'} += length($1);
+ $itempos[$#itempos]{'line'}{'from'} = $thisline;
+ $itempos[$#itempos]{'column'}{'from'} = $thiscolumn;
+ }
+}
+
+sub postitempos
+{
+ return q
+ {
+ $itempos[$#itempos]{'offset'}{'to'} = $prevoffset;
+ $itempos[$#itempos]{'line'}{'to'} = $prevline;
+ $itempos[$#itempos]{'column'}{'to'} = $prevcolumn;
+ }
+}
+
+sub code($$$$)
+{
+ my ($self,$namespace,$rule,$parser) = @_;
+ my $code =
+'
+ while (!$_matched'
+ . (defined $self->{"uncommit"} ? '' : ' && !$commit')
+ . ')
+ {
+ ' .
+ ($self->changesskip()
+ ? 'local $skip = defined($skip) ? $skip : $Parse::RecDescent::skip;'
+ : '') .'
+ Parse::RecDescent::_trace(q{Trying production: ['
+ . $self->describe . ']},
+ Parse::RecDescent::_tracefirst($_[1]),
+ q{' . $rule ->{name}. '},
+ $tracelevel)
+ if defined $::RD_TRACE;
+ my $thisprod = $thisrule->{"prods"}[' . $self->{"number"} . '];
+ ' . (defined $self->{"error"} ? '' : '$text = $_[1];' ) . '
+ my $_savetext;
+ @item = (q{' . $rule->{"name"} . '});
+ %item = (__RULE__ => q{' . $rule->{"name"} . '});
+ my $repcount = 0;
+
+';
+ $code .=
+' my @itempos = ({});
+' if $parser->{_check}{itempos};
+
+ my $item;
+ my $i;
+
+ 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
+ \"$rule->{name}\":
+ $parser->{_AUTOACTION}{code}")
+ and
+ Parse::RecDescent::_hint("The \$::RD_AUTOACTION was defined,
+ so any production not ending in an
+ 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{>>Matched production: ['
+ . $self->describe . ']<<},
+ Parse::RecDescent::_tracefirst($text),
+ q{' . $rule->{name} . '},
+ $tracelevel)
+ if defined $::RD_TRACE;
+ $_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{<<Didn\'t match action>> (return value: [undef])})
+ if defined $::RD_TRACE;
+ last;
+ }
+ Parse::RecDescent::_trace(q{>>Matched 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{>>Matched directive<< (return value: [}
+ . $_tok . q{])},
+ Parse::RecDescent::_tracefirst($text))
+ if defined $::RD_TRACE;
+ }
+ else
+ {
+ Parse::RecDescent::_trace(q{<<Didn\'t match 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" and $@)
+ {
+ Parse::RecDescent::_warn(3, "Token pattern \"m$ldel$pattern$rdel\"
+ 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;
+ $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 =~ s' . $ldel . '\A(?:' . $self->{"pattern"} . ')'
+ . $rdel . $sdel . $mod . ')
+ {
+ '.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
+ $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: [}
+ . $& . q{])},
+ Parse::RecDescent::_tracefirst($text))
+ if defined $::RD_TRACE;
+ push @item, $item{'.$self->{hashname}.'}=$&;
+ ' . ($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;
+ $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 =~ s/\A' . quotemeta($self->{"pattern"}) . '//)
+ {
+ '.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
+ $expectation->failed();
+ Parse::RecDescent::_trace(qq{<<Didn\'t match terminal>>},
+ Parse::RecDescent::_tracefirst($text))
+ if defined $::RD_TRACE;
+ last;
+ }
+ Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
+ . $& . q{])},
+ Parse::RecDescent::_tracefirst($text))
+ if defined $::RD_TRACE;
+ push @item, $item{'.$self->{hashname}.'}=$&;
+ ' . ($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;
+ $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;' : '').'
+ $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) = @_;
+
+'
+ 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 }')
+ . ')))
+ {
+ '.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
+ Parse::RecDescent::_trace(q{<<Didn\'t match subrule: ['
+ . $self->{subrule} . ']>>},
+ Parse::RecDescent::_tracefirst($text),
+ q{' . $rule->{"name"} .'},
+ $tracelevel)
+ if defined $::RD_TRACE;
+ $expectation->failed();
+ last;
+ }
+ Parse::RecDescent::_trace(q{>>Matched 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) = @_;
+
+ 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} }"
+ : 'undef')
+ . ')))
+ {
+ Parse::RecDescent::_trace(q{<<Didn\'t match repeated subrule: ['
+ . $self->describe . ']>>},
+ Parse::RecDescent::_tracefirst($text),
+ q{' . $rule->{"name"} .'},
+ $tracelevel)
+ if defined $::RD_TRACE;
+ last;
+ }
+ Parse::RecDescent::_trace(q{>>Matched 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) = @_;
+
+ 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;
+ ';
+
+ if ($self->{type} eq "leftop" )
+ {
+ $code .= '
+ # MATCH LEFTARG
+ ' . $leftarg->code(@_[1..2]) . '
+
+ $repcount++;
+
+ my $savetext = $text;
+ my $backtrack;
+
+ # MATCH (OP RIGHTARG)(s)
+ while ($repcount < ' . $self->{max} . ')
+ {
+ $backtrack = 0;
+ ' . $op->code(@_[1..2]) . '
+ ' . ($op->isterminal() ? 'pop @item;' : '$backtrack=1;' ) . '
+ ' . (ref($op) eq 'Parse::RecDescent::Token'
+ ? 'if (defined $1) {push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; $backtrack=1;}'
+ : "" ) . '
+ ' . $rightarg->code(@_[1..2]) . '
+ $savetext = $text;
+ $repcount++;
+ }
+ $text = $savetext;
+ pop @item if $backtrack;
+
+ ';
+ }
+ else
+ {
+ $code .= '
+ my $savetext = $text;
+ my $backtrack;
+ # MATCH (LEFTARG OP)(s)
+ while ($repcount < ' . $self->{max} . ')
+ {
+ $backtrack = 0;
+ ' . $leftarg->code(@_[1..2]) . '
+ $repcount++;
+ $backtrack = 1;
+ ' . $op->code(@_[1..2]) . '
+ $savetext = $text;
+ ' . ($op->isterminal() ? 'pop @item;' : "" ) . '
+ ' . (ref($op) eq 'Parse::RecDescent::Token' ? 'do { push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; } if defined $1;' : "" ) . '
+ }
+ $text = $savetext;
+ pop @item if $backtrack;
+
+ # MATCH RIGHTARG
+ ' . $rightarg->code(@_[1..2]) . '
+ $repcount++;
+ ';
+ }
+
+ $code .= 'unless (@item) { undef $_tok; last }' unless $self->{min}==0;
+
+ $code .= '
+ $_tok = [ @item ];
+ last;
+ }
+
+ unless ($repcount>='.$self->{min}.')
+ {
+ Parse::RecDescent::_trace(q{<<Didn\'t match operator: ['
+ . $self->describe
+ . ']>>},
+ Parse::RecDescent::_tracefirst($text),
+ q{' . $rule->{"name"} .'},
+ $tracelevel)
+ if defined $::RD_TRACE;
+ $expectation->failed();
+ last;
+ }
+ Parse::RecDescent::_trace(q{>>Matched 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 );
+
+my $ERRORS = 0;
+
+$VERSION = '1.94';
+
+# BUILDING A PARSER
+
+my $nextnamespace = "namespace000001";
+
+sub _nextnamespace()
+{
+ return "Parse::RecDescent::" . $nextnamespace++;
+}
+
+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,
+ };
+ 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;
+ shift;
+ return $self->Replace(@_)
+}
+
+sub Compile($$$$) {
+
+ die "Compilation of Parse::RecDescent grammars not yet implemented\n";
+}
+
+sub DESTROY {} # SO AUTOLOADER IGNORES IT
+
+# BUILDING A GRAMMAR....
+
+sub Replace ($$)
+{
+ splice(@_, 2, 0, 1);
+ return _generate(@_);
+}
+
+sub Extend ($$)
+{
+ splice(@_, 2, 0, 0);
+ return _generate(@_);
+}
+
+sub _no_rule ($$;$)
+{
+ _error("Ruleless $_[0] at start of grammar.",$_[1]);
+ my $desc = $_[2] ? "\"$_[2]\"" : "";
+ _hint("You need to define a rule for the $_[0] $desc
+ to be part of.");
+}
+
+my $NEGLOOKAHEAD = '\G(\s*\.\.\.\!)';
+my $POSLOOKAHEAD = '\G(\s*\.\.\.)';
+my $RULE = '\G\s*(\w+)[ \t]*:';
+my $PROD = '\G\s*([|])';
+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 $ACTION = '\G\s*\{';
+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(?:\s+([][()<>{}]+))?>';
+my $VARIABLEMK = '\G\s*<perl_variable>';
+my $NOCHECKMK = '\G\s*<nocheck>';
+my $AUTOTREEMK = '\G\s*<autotree>';
+my $AUTOSTUBMK = '\G\s*<autostub>';
+my $AUTORULEMK = '\G\s*<autorule:(.*?)>';
+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 $lines = 0;
+
+sub _generate($$$;$$)
+{
+ my ($self, $grammar, $replace, $isimplicit, $isleftop) = (@_, 0);
+
+ my $aftererror = 0;
+ my $lookahead = 0;
+ my $lookaheadspec = "";
+ $lines = _linecount($grammar) unless $lines;
+ $self->{_check}{itempos} = ($grammar =~ /\@itempos\b|\$itempos\s*\[/)
+ unless $self->{_check}{itempos};
+ for (qw(thisoffset thiscolumn prevline prevoffset prevcolumn))
+ {
+ $self->{_check}{$_} =
+ ($grammar =~ /\$$_/) || $self->{_check}{itempos}
+ unless $self->{_check}{$_};
+ }
+ my $line;
+
+ my $rule = undef;
+ my $prod = undef;
+ my $item = undef;
+ my $lastgreedy = '';
+ pos $grammar = 0;
+ study $grammar;
+
+ while (pos $grammar < length $grammar)
+ {
+ $line = $lines - _linecount($grammar) + 1;
+ my $commitonly;
+ my $code = "";
+ my @components = ();
+ if ($grammar =~ m/$COMMENT/gco)
+ {
+ _parse("a comment",0,$line);
+ next;
+ }
+ elsif ($grammar =~ m/$NEGLOOKAHEAD/gco)
+ {
+ _parse("a negative lookahead",$aftererror,$line);
+ $lookahead = $lookahead ? -$lookahead : -1;
+ $lookaheadspec .= $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;
+ $lookaheadspec .= $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 })
+ {
+ $code =~ s/\A\s*\(|\)\Z//g;
+ _parse("an implicit subrule", $aftererror, $line,
+ "( $code )");
+ my $implicit = $rule->nextimplicit;
+ $self->_generate("$implicit : $code",$replace,1);
+ my $pos = pos $grammar;
+ substr($grammar,$pos,0,$implicit);
+ pos $grammar = $pos;;
+ }
+ elsif ($grammar =~ m/$ENDDIRECTIVEMK/gco)
+ {
+
+ # EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)
+
+ my ($minrep,$maxrep) = (1,$MAXREP);
+ if ($grammar =~ m/\G[(]/gc)
+ {
+ pos($grammar)--;
+
+ if ($grammar =~ m/$OPTIONAL/gco)
+ { ($minrep, $maxrep) = (0,1) }
+ elsif ($grammar =~ m/$ANY/gco)
+ { $minrep = 0 }
+ elsif ($grammar =~ m/$EXACTLY/gco)
+ { ($minrep, $maxrep) = ($1,$1) }
+ elsif ($grammar =~ m/$BETWEEN/gco)
+ { ($minrep, $maxrep) = ($1,$2) }
+ elsif ($grammar =~ m/$ATLEAST/gco)
+ { $minrep = $1 }
+ elsif ($grammar =~ m/$ATMOST/gco)
+ { $maxrep = $1 }
+ elsif ($grammar =~ m/$MANY/gco)
+ { }
+ elsif ($grammar =~ m/$BADREP/gco)
+ {
+ _parse("an invalid repetition specifier", 0,$line);
+ _error("Incorrect specification of a repeated directive",
+ $line);
+ _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)
+ {
+ pos($grammar)-=2;
+
+ if ($grammar =~ m/$OPMK/gco)
+ {
+ # $DB::single=1;
+ _parse("a $1-associative operator directive", $aftererror, $line, "<$1op:...>");
+ $prod->adddirective($1, $line,$2||'');
+ }
+ 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(
+ 'my ($match,@res);
+ ($match,$text,undef,@res) =
+ Text::Balanced::extract_quotelike($text,$skip);
+ $match ? \@res : undef;
+ ', $lookahead,$line,"<perl_quotelike>");
+ $prod and $prod->additem($item)
+ or _no_rule("<perl_quotelike>",$line);
+ }
+ elsif ($grammar =~ m/$CODEBLOCKMK/gco)
+ {
+ my $outer = $1||"{}";
+ _parse("an perl codeblock marker", $aftererror,$line);
+ $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);
+ $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);
+ 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);
+ $::RD_AUTOSTUB = "";
+ }
+ elsif ($grammar =~ m/$AUTORULEMK/gco)
+ {
+ _parse("an autorule marker", $aftererror,$line);
+ $::RD_AUTOSTUB = $1;
+ }
+ elsif ($grammar =~ m/$AUTOTREEMK/gco)
+ {
+ _parse("an autotree marker", $aftererror,$line);
+ 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, $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,'<');
+ $code })
+ {
+ _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,'<');
+ $code })
+ {
+ _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,'<');
+ $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);
+ $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,'<');
+ $code })
+ {
+ _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 }',
+ $lookahead,$line,$code);
+ $prod and $prod->additem($item)
+ or _no_rule($code,$line);
+ }
+ elsif ($grammar =~ m/(?=$SKIPMK)/gco
+ and do { ($code) = extract_codeblock($grammar,'<');
+ $code })
+ {
+ _parse("a skip marker", $aftererror,$line);
+ $code =~ /\A\s*<skip:(.*)>\Z/s;
+ $item = new Parse::RecDescent::Directive(
+ 'my $oldskip = $skip; $skip='.$1.'; $oldskip',
+ $lookahead,$line,$code);
+ $prod and $prod->additem($item)
+ or _no_rule($code,$line);
+ }
+ elsif ($grammar =~ m/(?=$RULEVARPATMK)/gco
+ and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
+ $code;
+ } )
+ {
+ _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,'<');
+ $code;
+ } )
+ {
+ _parse("a deferred action specifier", $aftererror,$line,$code);
+ $code =~ s/\A\s*<defer:(.*)>\Z/$1/s;
+ if ($code =~ /\A\s*[^{]|[^}]\s*\Z/)
+ {
+ $code = "{ $code }"
+ }
+
+ $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);
+
+ $self->{deferrable} = 1;
+ }
+ elsif ($grammar =~ m/(?=$TOKENPATMK)/gco
+ and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
+ $code;
+ } )
+ {
+ _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' || ();
+ if (!$types)
+ {
+ _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:
+ <token:NOUN,VERB>");
+ }
+ else
+ {
+ $item = new Parse::RecDescent::Directive(
+ 'no strict;
+ $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)
+ {
+ $commitonly = $1;
+ _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,'<');
+ $code })
+ {
+ _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,'<');
+ $code })
+ {
+ if ($code =~ /^<[A-Z_]+>$/)
+ {
+ _error("Token items are not yet
+ supported: \"$code\"",
+ $line);
+ _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
+ \"$code\"?");
+ }
+ else
+ {
+ _error("Untranslatable item encountered: \"$code\"",
+ $line);
+ _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;
+ my $rulename = $1;
+ if ($rulename =~ /Replace|Extend|Precompile|Save/ )
+ {
+ _warn(2,"Rule \"$rulename\" hidden by method
+ Parse::RecDescent::$rulename",$line)
+ and
+ _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
+ parsers).");
+ }
+ $rule = new Parse::RecDescent::Rule($rulename,$self,$line,$replace);
+ $prod->check_pending($line) if $prod;
+ $prod = $rule->addprod( new Parse::RecDescent::Production );
+ $aftererror = 0;
+ }
+ elsif ($grammar =~ m/$UNCOMMITPROD/gco)
+ {
+ pos($grammar)-=9;
+ _parseunneg("a new (uncommitted) production",
+ 0, $lookahead, $line) or next;
+
+ $prod->check_pending($line) if $prod;
+ $prod = new Parse::RecDescent::Production($line,1);
+ $rule and $rule->addprod($prod)
+ or _no_rule("<uncommit>",$line);
+ $aftererror = 0;
+ }
+ elsif ($grammar =~ m/$ERRORPROD/gco)
+ {
+ pos($grammar)-=6;
+ _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);
+ $aftererror = 0;
+ }
+ elsif ($grammar =~ m/$PROD/gco)
+ {
+ _parseunneg("a new production", 0,
+ $lookahead,$line) or next;
+ $rule
+ and (!$prod || $prod->check_pending($line))
+ and $prod = $rule->addprod(new Parse::RecDescent::Production($line))
+ or _no_rule("production",$line);
+ $aftererror = 0;
+ }
+ 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);
+ $code }
+ )
+
+ {
+ _parse("an m/../ pattern terminal", $aftererror,$line,$code);
+ $item = new Parse::RecDescent::Token(@components[3,2,8],
+ $lookahead,$line);
+ $prod and $prod->additem($item)
+ or _no_rule("pattern terminal",$line,$code);
+ }
+ elsif ($grammar =~ m/(?=$MATCHRULE)/gco
+ and do { ($code) = extract_bracketed($grammar,'<');
+ $code
+ }
+ or $grammar =~ m/$SUBRULE/gco
+ and $code = $1)
+ {
+ my $name = $code;
+ my $matchrule = 0;
+ if (substr($name,0,1) eq '<')
+ {
+ $name =~ s/$MATCHRULE\s*//;
+ $name =~ s/\s*>\Z//;
+ $matchrule = 1;
+ }
+
+ # EXTRACT TRAILING ARG LIST (IF ANY)
+
+ my ($argcode) = extract_codeblock($grammar, "[]",'') || '';
+
+ # EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)
+
+ if ($grammar =~ m/\G[(]/gc)
+ {
+ pos($grammar)--;
+
+ 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,
+ $lookahead,$line,
+ $self,
+ $matchrule,
+ $argcode);
+ $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)");
+ if ($2)
+ {
+ my $pos = pos $grammar;
+ substr($grammar,$pos,0,
+ "<leftop='$name(s?)': $name $2 $name>(s?) ");
+
+ pos $grammar = $pos;
+ }
+ else
+ {
+ $item = new Parse::RecDescent::Repetition($name,$1,0,$MAXREP,
+ $lookahead,$line,
+ $self,
+ $matchrule,
+ $argcode);
+ $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)");
+ if ($2)
+ {
+ # $DB::single=1;
+ my $pos = pos $grammar;
+ substr($grammar,$pos,0,
+ "<leftop='$name(s)': $name $2 $name> ");
+
+ pos $grammar = $pos;
+ }
+ else
+ {
+ $item = new Parse::RecDescent::Repetition($name,$1,1,$MAXREP,
+ $lookahead,$line,
+ $self,
+ $matchrule,
+ $argcode);
+
+ $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)");
+ if ($2)
+ {
+ my $pos = pos $grammar;
+ substr($grammar,$pos,0,
+ "<leftop='$name($1)': $name $2 $name>($1) ");
+
+ pos $grammar = $pos;
+ }
+ else
+ {
+ $item = new Parse::RecDescent::Repetition($name,$1,$1,$1,
+ $lookahead,$line,
+ $self,
+ $matchrule,
+ $argcode);
+ $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)");
+ if ($3)
+ {
+ my $pos = pos $grammar;
+ substr($grammar,$pos,0,
+ "<leftop='$name($1..$2)': $name $3 $name>($1..$2) ");
+
+ pos $grammar = $pos;
+ }
+ else
+ {
+ $item = new Parse::RecDescent::Repetition($name,"$1..$2",$1,$2,
+ $lookahead,$line,
+ $self,
+ $matchrule,
+ $argcode);
+ $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..)");
+ if ($2)
+ {
+ my $pos = pos $grammar;
+ substr($grammar,$pos,0,
+ "<leftop='$name($1..)': $name $2 $name>($1..) ");
+
+ pos $grammar = $pos;
+ }
+ else
+ {
+ $item = new Parse::RecDescent::Repetition($name,"$1..",$1,$MAXREP,
+ $lookahead,$line,
+ $self,
+ $matchrule,
+ $argcode);
+ $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)");
+ if ($2)
+ {
+ my $pos = pos $grammar;
+ substr($grammar,$pos,0,
+ "<leftop='$name(..$1)': $name $2 $name>(..$1) ");
+
+ pos $grammar = $pos;
+ }
+ else
+ {
+ $item = new Parse::RecDescent::Repetition($name,"..$1",1,$1,
+ $lookahead,$line,
+ $self,
+ $matchrule,
+ $argcode);
+ $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",
+ $line);
+ _hint("Repeated subrules like \"$code$argcode$&\" cannot have
+ a maximum repetition of zero, nor can they have
+ negative components in their ranges.");
+ }
+ }
+ else
+ {
+ _parse("a subrule match", $aftererror,$line,$code);
+ my $desc;
+ if ($name=~/\A_alternation_\d+_of_production_\d+_of_rule/)
+ { $desc = $self->{"rules"}{$name}->expected }
+ $item = new Parse::RecDescent::Subrule($name,
+ $lookahead,
+ $line,
+ $desc,
+ $matchrule,
+ $argcode);
+
+ $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",
+ $line);
+ _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\"",
+ $line);
+ _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
+ row.",$line)
+ and
+ _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?");
+ }
+ $lookahead = 0;
+ $lookaheadspec = "";
+
+ $grammar =~ m/\G\s+/gc;
+ }
+
+ unless ($ERRORS or $isimplicit or !$::RD_CHECK)
+ {
+ $self->_check_grammar();
+ }
+
+ unless ($ERRORS or $isimplicit or $Parse::RecDescent::compiling)
+ {
+ my $code = $self->_code();
+ if (defined $::RD_TRACE)
+ {
+ print STDERR "printing code (", length($code),") to RD_TRACE\n";
+ local *TRACE_FILE;
+ open TRACE_FILE, ">RD_TRACE"
+ and print TRACE_FILE "my \$ERRORS;\n$code"
+ and close TRACE_FILE;
+ }
+
+ unless ( eval "$code 1" )
+ {
+ _error("Internal error in generated parser code!");
+ $@ =~ s/at grammar/in grammar at/;
+ _hint($@);
+ }
+ }
+
+ if ($ERRORS and !_verbosity("HINT"))
+ {
+ local $::RD_HINT = 1;
+ _hint('Set $::RD_HINT (or -RD_HINT if you\'re using "perl -s")
+ for hints on fixing these problems.');
+ }
+ if ($ERRORS) { $ERRORS=0; return }
+ return $self;
+}
+
+
+sub _addstartcode($$)
+{
+ my ($self, $code) = @_;
+ $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;
+ my $min = 1;
+ 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)
+ and
+ _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.");
+ }
+}
+
+sub _check_grammar ($)
+{
+ my $self = shift;
+ my $rules = $self->{"rules"};
+ my $rule;
+ foreach $rule ( values %$rules )
+ {
+ next if ! $rule->{"changed"};
+
+ # CHECK FOR UNDEFINED RULES
+
+ my $call;
+ foreach $call ( @{$rule->{"calls"}} )
+ {
+ if (!defined ${$rules}{$call}
+ &&!defined &{"Parse::RecDescent::$call"})
+ {
+ if (!defined $::RD_AUTOSTUB)
+ {
+ _warn(3,"Undefined (sub)rule \"$call\"
+ used in a production.")
+ and
+ _hint("Will you be providing this rule
+ later, or did you perhaps
+ misspell \"$call\"? Otherwise
+ it will be treated as an
+ immediate <reject>.");
+ eval "sub $self->{namespace}::$call {undef}";
+ }
+ else # EXPERIMENTAL
+ {
+ my $rule = $::RD_AUTOSTUB || qq{'$call'};
+ _warn(1,"Autogenerating rule: $call")
+ and
+ _hint("A call was made to a subrule
+ named \"$call\", but no such
+ rule was specified. However,
+ since \$::RD_AUTOSTUB
+ was defined, a rule stub
+ ($call : $rule) was
+ automatically created.");
+
+ $self->_generate("$call : $rule",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)\".");
+ next;
+ }
+ }
+}
+
+# GENERATE ACTUAL PARSER CODE
+
+sub _code($)
+{
+ my $self = shift;
+ my $code = qq{
+package $self->{namespace};
+use strict;
+use vars qw(\$skip \$AUTOLOAD $self->{localvars} );
+\$skip = '$skip';
+$self->{startcode}
+
+{
+local \$SIG{__WARN__} = sub {0};
+# PRETEND TO BE IN Parse::RecDescent NAMESPACE
+*$self->{namespace}::AUTOLOAD = sub
+{
+ no strict 'refs';
+ \$AUTOLOAD =~ s/^$self->{namespace}/Parse::RecDescent/;
+ goto &{\$AUTOLOAD};
+}
+}
+
+};
+ $code .= "push \@$self->{namespace}\::ISA, 'Parse::RecDescent';";
+ $self->{"startcode"} = '';
+
+ my $rule;
+ foreach $rule ( values %{$self->{"rules"}} )
+ {
+ if ($rule->{"changed"})
+ {
+ $code .= $rule->code($self->{"namespace"},$self);
+ $rule->{"changed"} = 0;
+ }
+ }
+
+ return $code;
+}
+
+
+# EXECUTING A PARSE....
+
+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]->{lastlinenum} = _linecount($_[1]);
+ $_[0]->{lastlinenum} += $_[2] if @_ > 2;
+ $_[0]->{offsetlinenum} = $_[0]->{lastlinenum};
+ $_[0]->{fulltext} = $text;
+ $_[0]->{fulltextlen} = length $text;
+ $_[0]->{deferred} = [];
+ $_[0]->{errors} = [];
+ my @args = @_[3..$#_];
+ my $args = sub { [ @args ] };
+
+ $AUTOLOAD =~ s/$class/$_[0]->{namespace}/;
+ no strict "refs";
+
+ croak "Unknown starting rule ($AUTOLOAD) called\n"
+ unless defined &$AUTOLOAD;
+ my $retval = &{$AUTOLOAD}($_[0],$text,undef,undef,$args);
+
+ if (defined $retval)
+ {
+ foreach ( @{$_[0]->{deferred}} ) { &$_; }
+ }
+ else
+ {
+ foreach ( @{$_[0]->{errors}} ) { _error(@$_); }
+ }
+
+ if (ref $_[1]) { ${$_[1]} = $text }
+
+ $ERRORS = 0;
+ return $retval;
+}
+
+sub _parserepeat($$$$$$$$$$) # RETURNS A REF TO AN ARRAY OF MATCHES
+{
+ my ($parser, $text, $prod, $min, $max, $_noactions, $expectation, $argcode) = @_;
+ my @tokens = ();
+
+ my $reps;
+ for ($reps=0; $reps<$max;)
+ {
+ $_[6]->at($text); # $_[6] IS $expectation FROM CALLER
+ my $_savetext = $text;
+ my $prevtextlen = length $text;
+ my $_tok;
+ if (! defined ($_tok = &$prod($parser,$text,1,$_noactions,$argcode)))
+ {
+ $text = $_savetext;
+ last;
+ }
+ push @tokens, $_tok if defined $_tok;
+ last if ++$reps >= $min and $prevtextlen == length $text;
+ }
+
+ do { $_[6]->failed(); return undef} if $reps<$min;
+
+ $_[1] = $text;
+ return [@tokens];
+}
+
+
+# ERROR REPORTING....
+
+my $errortext;
+my $errorprefix;
+
+open (ERROR, ">&STDERR");
+format ERROR =
+@>>>>>>>>>>>>>>>>>>>>: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$errorprefix, $errortext
+~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $errortext
+.
+
+select ERROR;
+$| = 1;
+
+# TRACING
+
+my $tracemsg;
+my $tracecontext;
+my $tracerulename;
+use vars '$tracelevel';
+
+open (TRACE, ">&STDERR");
+format TRACE =
+@>|@|||||||||@^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
+$tracelevel, $tracerulename, '|', $tracemsg
+ | ~~ |^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
+ $tracemsg
+.
+
+select TRACE;
+$| = 1;
+
+open (TRACECONTEXT, ">&STDERR");
+format TRACECONTEXT =
+@>|@|||||||||@ |^<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$tracelevel, $tracerulename, '|', $tracecontext
+ | ~~ | |^<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $tracecontext
+.
+
+
+select TRACECONTEXT;
+$| = 1;
+
+select STDOUT;
+
+sub _verbosity($)
+{
+ defined $::RD_TRACE
+ or defined $::RD_HINT and $_[0] =~ /ERRORS|WARN|HINT/
+ or defined $::RD_WARN and $_[0] =~ /ERRORS|WARN/
+ or defined $::RD_ERRORS and $_[0] =~ /ERRORS/
+}
+
+sub _error($;$)
+{
+ $ERRORS++;
+ return 0 if ! _verbosity("ERRORS");
+ $errortext = $_[0];
+ $errorprefix = "ERROR" . ($_[1] ? " (line $_[1])" : "");
+ $errortext =~ s/\s+/ /g;
+ print ERROR "\n" if _verbosity("WARN");
+ write ERROR;
+ return 1;
+}
+
+sub _warn($$;$)
+{
+ return 0 unless _verbosity("WARN") && ($::RD_HINT || $_[0] >= ($::RD_WARN||1));
+ $errortext = $_[1];
+ $errorprefix = "Warning" . ($_[2] ? " (line $_[2])" : "");
+ print ERROR "\n";
+ $errortext =~ s/\s+/ /g;
+ write ERROR;
+ return 1;
+}
+
+sub _hint($)
+{
+ return 0 unless defined $::RD_HINT;
+ $errortext = "$_[0])";
+ $errorprefix = "(Hint";
+ $errortext =~ s/\s+/ /g;
+ write ERROR;
+ return 1;
+}
+
+sub _tracemax($)
+{
+ if (defined $::RD_TRACE
+ && $::RD_TRACE =~ /\d+/
+ && $::RD_TRACE>1
+ && $::RD_TRACE+10<length($_[0]))
+ {
+ my $count = length($_[0]) - $::RD_TRACE;
+ return substr($_[0],0,$::RD_TRACE/2)
+ . "...<$count>..."
+ . substr($_[0],-$::RD_TRACE/2);
+ }
+ else
+ {
+ return $_[0];
+ }
+}
+
+sub _tracefirst($)
+{
+ if (defined $::RD_TRACE
+ && $::RD_TRACE =~ /\d+/
+ && $::RD_TRACE>1
+ && $::RD_TRACE+10<length($_[0]))
+ {
+ my $count = length($_[0]) - $::RD_TRACE;
+ return substr($_[0],0,$::RD_TRACE) . "...<+$count>";
+ }
+ else
+ {
+ return $_[0];
+ }
+}
+
+my $lastcontext = '';
+my $lastrulename = '';
+my $lastlevel = '';
+
+sub _trace($;$$$)
+{
+ $tracemsg = $_[0];
+ $tracecontext = $_[1]||$lastcontext;
+ $tracerulename = $_[2]||$lastrulename;
+ $tracelevel = $_[3]||$lastlevel;
+ if ($tracerulename) { $lastrulename = $tracerulename }
+ if ($tracelevel) { $lastlevel = $tracelevel }
+
+ $tracecontext =~ s/\n/\\n/g;
+ $tracecontext =~ s/\s+/ /g;
+ $tracerulename = qq{$tracerulename};
+ write TRACE;
+ if ($tracecontext ne $lastcontext)
+ {
+ if ($tracecontext)
+ {
+ $lastcontext = _tracefirst($tracecontext);
+ $tracecontext = qq{"$tracecontext"};
+ }
+ else
+ {
+ $tracecontext = qq{<NO TEXT LEFT>};
+ }
+ write TRACECONTEXT;
+ }
+}
+
+sub _parseunneg($$$$)
+{
+ _parse($_[0],$_[1],$_[3]);
+ if ($_[2]<0)
+ {
+ _error("Can't negate \"$&\".",$_[3]);
+ _hint("You can't negate $_[0]. Remove the \"...!\" before
+ \"$&\".");
+ return 0;
+ }
+ return 1;
+}
+
+sub _parse($$$;$)
+{
+ my $what = $_[3] || $&;
+ $what =~ s/^\s+//;
+ if ($_[1])
+ {
+ _warn(3,"Found $_[0] ($what) after an unconditional <error>",$_[2])
+ and
+ _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
+ <error?> instead?");
+ }
+
+ return if ! _verbosity("TRACE");
+ $errortext = "Treating \"$what\" as $_[0]";
+ $errorprefix = "Parse::RecDescent";
+ $errortext =~ s/\s+/ /g;
+ write ERROR;
+}
+
+sub _linecount($) {
+ scalar substr($_[0], pos $_[0]||0) =~ tr/\n//
+}
+
+
+package main;
+
+use vars qw ( $RD_ERRORS $RD_WARN $RD_HINT $RD_TRACE $RD_CHECK );
+$::RD_CHECK = 1;
+$::RD_ERRORS = 1;
+$::RD_WARN = 3;
+
+1;
+
diff --git a/source4/build/pidl/lib/README b/source4/build/pidl/lib/README
new file mode 100644
index 0000000000..a02b3f59be
--- /dev/null
+++ b/source4/build/pidl/lib/README
@@ -0,0 +1,11 @@
+Many thanks to Damian Conway for his excellent Parse::Recdescent
+package. I have included a copy of it here to prevent problems with
+differing versions and pidl. The original package is distributed with
+the following copyright:
+
+COPYRIGHT
+
+ Copyright (c) 1997-2000, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the terms of the Perl Artistic License
+ (see http://www.perl.com/perl/misc/Artistic.html)
diff --git a/source4/build/pidl/pidl.pl b/source4/build/pidl/pidl.pl
index 49bd2e3b57..73d2378612 100755
--- a/source4/build/pidl/pidl.pl
+++ b/source4/build/pidl/pidl.pl
@@ -10,6 +10,7 @@ use strict;
use FindBin qw($RealBin);
use lib "$RealBin";
+use lib "$RealBin/lib";
use Getopt::Long;
use idl;
use dump;