home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / RecDescent.pm < prev    next >
Encoding:
Text File  |  2003-04-09  |  78.6 KB  |  3,046 lines
  1. # GENERATE RECURSIVE DESCENT PARSER OBJECTS FROM A GRAMMARC
  2. # SEE RecDescent.pod FOR FULL DETAILS
  3.  
  4. use 5.005;
  5. use strict;
  6.  
  7. package Parse::RecDescent;
  8.  
  9. use Text::Balanced qw ( extract_codeblock extract_bracketed extract_quotelike extract_delimited );
  10.  
  11. use vars qw ( $skip );
  12.  
  13.    *defskip  = \ '\s*';    # DEFAULT SEPARATOR IS OPTIONAL WHITESPACE
  14.    $skip  = '\s*';        # UNIVERSAL SEPARATOR IS OPTIONAL WHITESPACE
  15. my $MAXREP  = 100_000_000;    # REPETITIONS MATCH AT MOST 100,000,000 TIMES
  16.  
  17.  
  18. sub import    # IMPLEMENT PRECOMPILER BEHAVIOUR UNDER:
  19.         #    perl -MParse::RecDescent - <grammarfile> <classname>
  20. {
  21.     local *_die = sub { print @_, "\n"; exit };
  22.  
  23.     my ($package, $file, $line) = caller;
  24.     if (substr($file,0,1) eq '-' && $line == 0)
  25.     {
  26.         _die("Usage: perl -MLocalTest - <grammarfile> <classname>")
  27.             unless @ARGV == 2;
  28.  
  29.         my ($sourcefile, $class) = @ARGV;
  30.  
  31.         local *IN;
  32.         open IN, $sourcefile
  33.             or _die("Can't open grammar file '$sourcefile'");
  34.  
  35.         my $grammar = join '', <IN>;
  36.  
  37.         Parse::RecDescent->Precompile($grammar, $class, $sourcefile);
  38.         exit;
  39.     }
  40. }
  41.         
  42. sub Save
  43. {
  44.     my ($self, $class) = @_;
  45.     $self->{saving} = 1;
  46.     $self->Precompile(undef,$class);
  47.     $self->{saving} = 0;
  48. }
  49.  
  50. sub Precompile
  51. {
  52.         my ($self, $grammar, $class, $sourcefile) = @_;
  53.  
  54.         $class =~ /^(\w+::)*\w+$/ or croak("Bad class name: $class");
  55.  
  56.         my $modulefile = $class;
  57.         $modulefile =~ s/.*:://;
  58.         $modulefile .= ".pm";
  59.  
  60.         open OUT, ">$modulefile"
  61.             or croak("Can't write to new module file '$modulefile'");
  62.  
  63.         print STDERR "precompiling grammar from file '$sourcefile'\n",
  64.                  "to class $class in module file '$modulefile'\n"
  65.                     if $grammar && $sourcefile;
  66.  
  67.         # local $::RD_HINT = 1;
  68.         $self = Parse::RecDescent->new($grammar,1,$class)
  69.             || croak("Can't compile bad grammar")
  70.                 if $grammar;
  71.  
  72.         foreach ( keys %{$self->{rules}} )
  73.             { $self->{rules}{$_}{changed} = 1 }
  74.  
  75.         print OUT "package $class;\nuse Parse::RecDescent;\n\n";
  76.  
  77.         print OUT "{ my \$ERRORS;\n\n";
  78.  
  79.         print OUT $self->_code();
  80.  
  81.         print OUT "}\npackage $class; sub new { ";
  82.         print OUT "my ";
  83.  
  84.         require Data::Dumper;
  85.         print OUT Data::Dumper->Dump([$self], [qw(self)]);
  86.  
  87.         print OUT "}";
  88.  
  89.         close OUT
  90.             or croak("Can't write to new module file '$modulefile'");
  91. }
  92.  
  93.  
  94. package Parse::RecDescent::LineCounter;
  95.  
  96.  
  97. sub TIESCALAR    # ($classname, \$text, $thisparser, $prevflag)
  98. {
  99.     bless {
  100.         text    => $_[1],
  101.         parser  => $_[2],
  102.         prev    => $_[3]?1:0,
  103.           }, $_[0];
  104. }
  105.  
  106. my %counter_cache;
  107.  
  108. sub FETCH
  109. {
  110.         my $parser = $_[0]->{parser};
  111.         my $from = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}
  112. ;
  113.  
  114.     unless (exists $counter_cache{$from}) {
  115.         $parser->{lastlinenum} = $parser->{offsetlinenum}
  116.            - Parse::RecDescent::_linecount(substr($parser->{fulltext},$from))
  117.                    + 1;
  118.         $counter_cache{$from} = $parser->{lastlinenum};
  119.     }
  120.     return $counter_cache{$from};
  121. }
  122.  
  123. sub STORE
  124. {
  125.     my $parser = $_[0]->{parser};
  126.     $parser->{offsetlinenum} -= $parser->{lastlinenum} - $_[1];
  127.     return undef;
  128. }
  129.  
  130. sub resync       # ($linecounter)
  131. {
  132.         my $self = tied($_[0]);
  133.         die "Tried to alter something other than a LineCounter\n"
  134.                 unless $self =~ /Parse::RecDescent::LineCounter/;
  135.     
  136.     my $parser = $self->{parser};
  137.     my $apparently = $parser->{offsetlinenum}
  138.              - Parse::RecDescent::_linecount(${$self->{text}})
  139.              + 1;
  140.  
  141.     $parser->{offsetlinenum} += $parser->{lastlinenum} - $apparently;
  142.     return 1;
  143. }
  144.  
  145. package Parse::RecDescent::ColCounter;
  146.  
  147. sub TIESCALAR    # ($classname, \$text, $thisparser, $prevflag)
  148. {
  149.     bless {
  150.         text    => $_[1],
  151.         parser  => $_[2],
  152.         prev    => $_[3]?1:0,
  153.           }, $_[0];
  154. }
  155.  
  156. sub FETCH    
  157. {
  158.     my $parser = $_[0]->{parser};
  159.     my $missing = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}+1;
  160.     substr($parser->{fulltext},0,$missing) =~ m/^(.*)\Z/m;
  161.     return length($1);
  162. }
  163.  
  164. sub STORE
  165. {
  166.     die "Can't set column number via \$thiscolumn\n";
  167. }
  168.  
  169.  
  170. package Parse::RecDescent::OffsetCounter;
  171.  
  172. sub TIESCALAR    # ($classname, \$text, $thisparser, $prev)
  173. {
  174.     bless {
  175.         text    => $_[1],
  176.         parser  => $_[2],
  177.         prev    => $_[3]?-1:0,
  178.           }, $_[0];
  179. }
  180.  
  181. sub FETCH    
  182. {
  183.     my $parser = $_[0]->{parser};
  184.     return $parser->{fulltextlen}-length(${$_[0]->{text}})+$_[0]->{prev};
  185. }
  186.  
  187. sub STORE
  188. {
  189.     die "Can't set current offset via \$thisoffset or \$prevoffset\n";
  190. }
  191.  
  192.  
  193.  
  194. package Parse::RecDescent::Rule;
  195.  
  196. sub new ($$$$$)
  197. {
  198.     my $class = ref($_[0]) || $_[0];
  199.     my $name  = $_[1];
  200.     my $owner = $_[2];
  201.     my $line  = $_[3];
  202.     my $replace = $_[4];
  203.  
  204.     if (defined $owner->{"rules"}{$name})
  205.     {
  206.         my $self = $owner->{"rules"}{$name};
  207.         if ($replace && !$self->{"changed"})
  208.         {
  209.             $self->reset;
  210.         }
  211.         return $self;
  212.     }
  213.     else
  214.     {
  215.         return $owner->{"rules"}{$name} =
  216.             bless
  217.             {
  218.                 "name"     => $name,
  219.                 "prods"    => [],
  220.                 "calls"    => [],
  221.                 "changed"  => 0,
  222.                 "line"     => $line,
  223.                 "impcount" => 0,
  224.                 "opcount"  => 0,
  225.                 "vars"       => "",
  226.             }, $class;
  227.     }
  228. }
  229.  
  230. sub reset($)
  231. {
  232.     @{$_[0]->{"prods"}} = ();
  233.     @{$_[0]->{"calls"}} = ();
  234.     $_[0]->{"changed"}  = 0;
  235.     $_[0]->{"impcount"}  = 0;
  236.     $_[0]->{"opcount"}  = 0;
  237.     $_[0]->{"vars"}  = "";
  238. }
  239.  
  240. sub DESTROY {}
  241.  
  242. sub hasleftmost($$)
  243. {
  244.     my ($self, $ref) = @_;
  245.  
  246.     my $prod;
  247.     foreach $prod ( @{$self->{"prods"}} )
  248.     {
  249.         return 1 if $prod->hasleftmost($ref);
  250.     }
  251.  
  252.     return 0;
  253. }
  254.  
  255. sub leftmostsubrules($)
  256. {
  257.     my $self = shift;
  258.     my @subrules = ();
  259.  
  260.     my $prod;
  261.     foreach $prod ( @{$self->{"prods"}} )
  262.     {
  263.         push @subrules, $prod->leftmostsubrule();
  264.     }
  265.  
  266.     return @subrules;
  267. }
  268.  
  269. sub expected($)
  270. {
  271.     my $self = shift;
  272.     my @expected = ();
  273.  
  274.     my $prod;
  275.     foreach $prod ( @{$self->{"prods"}} )
  276.     {
  277.         my $next = $prod->expected();
  278.         unless (! $next or _contains($next,@expected) )
  279.         {
  280.             push @expected, $next;
  281.         }
  282.     }
  283.  
  284.     return join ', or ', @expected;
  285. }
  286.  
  287. sub _contains($@)
  288. {
  289.     my $target = shift;
  290.     my $item;
  291.     foreach $item ( @_ ) { return 1 if $target eq $item; }
  292.     return 0;
  293. }
  294.  
  295. sub addcall($$)
  296. {
  297.     my ( $self, $subrule ) = @_;
  298.     unless ( _contains($subrule, @{$self->{"calls"}}) )
  299.     {
  300.         push @{$self->{"calls"}}, $subrule;
  301.     }
  302. }
  303.  
  304. sub addprod($$)
  305. {
  306.     my ( $self, $prod ) = @_;
  307.     push @{$self->{"prods"}}, $prod;
  308.     $self->{"changed"} = 1;
  309.     $self->{"impcount"} = 0;
  310.     $self->{"opcount"} = 0;
  311.     $prod->{"number"} = $#{$self->{"prods"}};
  312.     return $prod;
  313. }
  314.  
  315. sub addvar
  316. {
  317.     my ( $self, $var, $parser ) = @_;
  318.     if ($var =~ /\A\s*local\s+([%@\$]\w+)/)
  319.     {
  320.         $parser->{localvars} .= " $1";
  321.         $self->{"vars"} .= "$var;\n" }
  322.     else 
  323.         { $self->{"vars"} .= "my $var;\n" }
  324.     $self->{"changed"} = 1;
  325.     return 1;
  326. }
  327.  
  328. sub addautoscore
  329. {
  330.     my ( $self, $code ) = @_;
  331.     $self->{"autoscore"} = $code;
  332.     $self->{"changed"} = 1;
  333.     return 1;
  334. }
  335.  
  336. sub nextoperator($)
  337. {
  338.     my $self = shift;
  339.     my $prodcount = scalar @{$self->{"prods"}};
  340.     my $opcount = ++$self->{"opcount"};
  341.     return "_operator_${opcount}_of_production_${prodcount}_of_rule_$self->{name}";
  342. }
  343.  
  344. sub nextimplicit($)
  345. {
  346.     my $self = shift;
  347.     my $prodcount = scalar @{$self->{"prods"}};
  348.     my $impcount = ++$self->{"impcount"};
  349.     return "_alternation_${impcount}_of_production_${prodcount}_of_rule_$self->{name}";
  350. }
  351.  
  352.  
  353. sub code
  354. {
  355.     my ($self, $namespace, $parser) = @_;
  356.  
  357. eval 'undef &' . $namespace . '::' . $self->{"name"} unless $parser->{saving};
  358.  
  359.     my $code =
  360. '
  361. # ARGS ARE: ($parser, $text; $repeating, $_noactions, \@args)
  362. sub ' . $namespace . '::' . $self->{"name"} .  '
  363. {
  364.     my $thisparser = $_[0];
  365.     use vars q{$tracelevel};
  366.     local $tracelevel = ($tracelevel||0)+1;
  367.     $ERRORS = 0;
  368.     my $thisrule = $thisparser->{"rules"}{"' . $self->{"name"} . '"};
  369.     
  370.     Parse::RecDescent::_trace(q{Trying rule: [' . $self->{"name"} . ']},
  371.                   Parse::RecDescent::_tracefirst($_[1]),
  372.                   q{' . $self->{"name"} . '},
  373.                   $tracelevel)
  374.                     if defined $::RD_TRACE;
  375.  
  376.     ' . ($parser->{deferrable}
  377.         ? 'my $def_at = @{$thisparser->{deferred}};'
  378.         : '') .
  379.     '
  380.     my $err_at = @{$thisparser->{errors}};
  381.  
  382.     my $score;
  383.     my $score_return;
  384.     my $_tok;
  385.     my $return = undef;
  386.     my $_matched=0;
  387.     my $commit=0;
  388.     my @item = ();
  389.     my %item = ();
  390.     my $repeating =  defined($_[2]) && $_[2];
  391.     my $_noactions = defined($_[3]) && $_[3];
  392.      my @arg =        defined $_[4] ? @{ &{$_[4]} } : ();
  393.     my %arg =        ($#arg & 01) ? @arg : (@arg, undef);
  394.     my $text;
  395.     my $lastsep="";
  396.     my $expectation = new Parse::RecDescent::Expectation($thisrule->expected());
  397.     $expectation->at($_[1]);
  398.     '. ($parser->{_check}{thisoffset}?'
  399.     my $thisoffset;
  400.     tie $thisoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser;
  401.     ':'') . ($parser->{_check}{prevoffset}?'
  402.     my $prevoffset;
  403.     tie $prevoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser, 1;
  404.     ':'') . ($parser->{_check}{thiscolumn}?'
  405.     my $thiscolumn;
  406.     tie $thiscolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser;
  407.     ':'') . ($parser->{_check}{prevcolumn}?'
  408.     my $prevcolumn;
  409.     tie $prevcolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser, 1;
  410.     ':'') . ($parser->{_check}{prevline}?'
  411.     my $prevline;
  412.     tie $prevline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser, 1;
  413.     ':'') . '
  414.     my $thisline;
  415.     tie $thisline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser;
  416.  
  417.     '. $self->{vars} .'
  418. ';
  419.  
  420.     my $prod;
  421.     foreach $prod ( @{$self->{"prods"}} )
  422.     {
  423.         $prod->addscore($self->{autoscore},0,0) if $self->{autoscore};
  424.         next unless $prod->checkleftmost();
  425.         $code .= $prod->code($namespace,$self,$parser);
  426.  
  427.         $code .= $parser->{deferrable}
  428.                 ? '        splice
  429.                 @{$thisparser->{deferred}}, $def_at unless $_matched;
  430.                   '
  431.                 : '';
  432.     }
  433.  
  434.     $code .=
  435. '
  436.         unless ( $_matched || defined($return) || defined($score) )
  437.     {
  438.         ' .($parser->{deferrable}
  439.             ? '        splice @{$thisparser->{deferred}}, $def_at;
  440.               '
  441.             : '') . '
  442.  
  443.         $_[1] = $text;    # NOT SURE THIS IS NEEDED
  444.         Parse::RecDescent::_trace(q{<<Didn\'t match rule>>},
  445.                      Parse::RecDescent::_tracefirst($_[1]),
  446.                      q{' . $self->{"name"} .'},
  447.                      $tracelevel)
  448.                     if defined $::RD_TRACE;
  449.         return undef;
  450.     }
  451.     if (!defined($return) && defined($score))
  452.     {
  453.         Parse::RecDescent::_trace(q{>>Accepted scored production<<}, "",
  454.                       q{' . $self->{"name"} .'},
  455.                       $tracelevel)
  456.                         if defined $::RD_TRACE;
  457.         $return = $score_return;
  458.     }
  459.     splice @{$thisparser->{errors}}, $err_at;
  460.     $return = $item[$#item] unless defined $return;
  461.     if (defined $::RD_TRACE)
  462.     {
  463.         Parse::RecDescent::_trace(q{>>Matched rule<< (return value: [} .
  464.                       $return . q{])}, "",
  465.                       q{' . $self->{"name"} .'},
  466.                       $tracelevel);
  467.         Parse::RecDescent::_trace(q{(consumed: [} .
  468.                       Parse::RecDescent::_tracemax(substr($_[1],0,-length($text))) . q{])}, 
  469.                       Parse::RecDescent::_tracefirst($text),
  470.                       , q{' . $self->{"name"} .'},
  471.                       $tracelevel)
  472.     }
  473.     $_[1] = $text;
  474.     return $return;
  475. }
  476. ';
  477.  
  478.     return $code;
  479. }
  480.  
  481. my @left;
  482. sub isleftrec($$)
  483. {
  484.     my ($self, $rules) = @_;
  485.     my $root = $self->{"name"};
  486.     @left = $self->leftmostsubrules();
  487.     my $next;
  488.     foreach $next ( @left )
  489.     {
  490.         next unless defined $rules->{$next}; # SKIP NON-EXISTENT RULES
  491.         return 1 if $next eq $root;
  492.         my $child;
  493.         foreach $child ( $rules->{$next}->leftmostsubrules() )
  494.         {
  495.             push(@left, $child)
  496.             if ! _contains($child, @left) ;
  497.         }
  498.     }
  499.     return 0;
  500. }
  501.  
  502. package Parse::RecDescent::Production;
  503.  
  504. sub describe ($;$)
  505. {
  506.     return join ' ', map { $_->describe($_[1]) or () } @{$_[0]->{items}};
  507. }
  508.  
  509. sub new ($$;$$)
  510. {
  511.     my ($self, $line, $uncommit, $error) = @_;
  512.     my $class = ref($self) || $self;
  513.  
  514.     bless
  515.     {
  516.         "items"    => [],
  517.         "uncommit" => $uncommit,
  518.         "error"    => $error,
  519.         "line"     => $line,
  520.         strcount   => 0,
  521.         patcount   => 0,
  522.         dircount   => 0,
  523.         actcount   => 0,
  524.     }, $class;
  525. }
  526.  
  527. sub expected ($)
  528. {
  529.     my $itemcount = scalar @{$_[0]->{"items"}};
  530.     return ($itemcount) ? $_[0]->{"items"}[0]->describe(1) : '';
  531. }
  532.  
  533. sub hasleftmost ($$)
  534. {
  535.     my ($self, $ref) = @_;
  536.     return ${$self->{"items"}}[0] eq $ref  if scalar @{$self->{"items"}};
  537.     return 0;
  538. }
  539.  
  540. sub leftmostsubrule($)
  541. {
  542.     my $self = shift;
  543.  
  544.     if ( $#{$self->{"items"}} >= 0 )
  545.     {
  546.         my $subrule = $self->{"items"}[0]->issubrule();
  547.         return $subrule if defined $subrule;
  548.     }
  549.  
  550.     return ();
  551. }
  552.  
  553. sub checkleftmost($)
  554. {
  555.     my @items = @{$_[0]->{"items"}};
  556.     if (@items==1 && ref($items[0]) =~ /\AParse::RecDescent::Error/
  557.         && $items[0]->{commitonly} )
  558.     {
  559.         Parse::RecDescent::_warn(2,"Lone <error?> in production treated
  560.                         as <error?> <reject>");
  561.         Parse::RecDescent::_hint("A production consisting of a single
  562.                       conditional <error?> directive would 
  563.                       normally succeed (with the value zero) if the
  564.                       rule is not 'commited' when it is
  565.                       tried. Since you almost certainly wanted
  566.                       '<error?> <reject>' Parse::RecDescent
  567.                       supplied it for you.");
  568.         push @{$_[0]->{items}},
  569.             Parse::RecDescent::UncondReject->new(0,0,'<reject>');
  570.     }
  571.     elsif (@items==1 && ($items[0]->describe||"") =~ /<rulevar|<autoscore/)
  572.     {
  573.         # Do nothing
  574.     }
  575.     elsif (@items &&
  576.         ( ref($items[0]) =~ /\AParse::RecDescent::UncondReject/
  577.         || ($items[0]->describe||"") =~ /<autoscore/
  578.         ))
  579.     {
  580.         Parse::RecDescent::_warn(1,"Optimizing away production: [". $_[0]->describe ."]");
  581.         my $what = $items[0]->describe =~ /<rulevar/
  582.                 ? "a <rulevar> (which acts like an unconditional <reject> during parsing)"
  583.                  : $items[0]->describe =~ /<autoscore/
  584.                 ? "an <autoscore> (which acts like an unconditional <reject> during parsing)"
  585.                 : "an unconditional <reject>";
  586.         my $caveat = $items[0]->describe =~ /<rulevar/
  587.                 ? " after the specified variable was set up"
  588.                 : "";
  589.         my $advice = @items > 1
  590.                 ? "However, there were also other (useless) items after the leading "
  591.                   . $items[0]->describe
  592.                   . ", so you may have been expecting some other behaviour."
  593.                 : "You can safely ignore this message.";
  594.         Parse::RecDescent::_hint("The production starts with $what. That means that the
  595.                       production can never successfully match, so it was
  596.                       optimized out of the final parser$caveat. $advice");
  597.         return 0;
  598.     }
  599.     return 1;
  600. }
  601.  
  602. sub changesskip($)
  603. {
  604.     my $item;
  605.     foreach $item (@{$_[0]->{"items"}})
  606.     {
  607.         if (ref($item) =~ /Parse::RecDescent::(Action|Directive)/)
  608.         {
  609.             return 1 if $item->{code} =~ /\$skip/;
  610.         }
  611.     }
  612.     return 0;
  613. }
  614.  
  615. sub adddirective
  616. {
  617.     my ( $self, $whichop, $line, $name ) = @_;
  618.     push @{$self->{op}},
  619.         { type=>$whichop, line=>$line, name=>$name,
  620.           offset=> scalar(@{$self->{items}}) };
  621. }
  622.  
  623. sub addscore
  624. {
  625.     my ( $self, $code, $lookahead, $line ) = @_;
  626.     $self->additem(Parse::RecDescent::Directive->new(
  627.                   "local \$^W;
  628.                    my \$thisscore = do { $code } + 0;
  629.                    if (!defined(\$score) || \$thisscore>\$score)
  630.                     { \$score=\$thisscore; \$score_return=\$item[-1]; }
  631.                    undef;", $lookahead, $line,"<score: $code>") )
  632.         unless $self->{items}[-1]->describe =~ /<score/;
  633.     return 1;
  634. }
  635.  
  636. sub check_pending
  637. {
  638.     my ( $self, $line ) = @_;
  639.     if ($self->{op})
  640.     {
  641.         while (my $next = pop @{$self->{op}})
  642.         {
  643.         Parse::RecDescent::_error("Incomplete <$next->{type}op:...>.", $line);
  644.         Parse::RecDescent::_hint(
  645.             "The current production ended without completing the
  646.              <$next->{type}op:...> directive that started near line
  647.              $next->{line}. Did you forget the closing '>'?");
  648.         }
  649.     }
  650.     return 1;
  651. }
  652.  
  653. sub enddirective
  654. {
  655.     my ( $self, $line, $minrep, $maxrep ) = @_;
  656.     unless ($self->{op})
  657.     {
  658.         Parse::RecDescent::_error("Unmatched > found.", $line);
  659.         Parse::RecDescent::_hint(
  660.             "A '>' angle bracket was encountered, which typically
  661.              indicates the end of a directive. However no suitable
  662.              preceding directive was encountered. Typically this
  663.              indicates either a extra '>' in the grammar, or a
  664.              problem inside the previous directive.");
  665.         return;
  666.     }
  667.     my $op = pop @{$self->{op}};
  668.     my $span = @{$self->{items}} - $op->{offset};
  669.     if ($op->{type} =~ /left|right/)
  670.     {
  671.         if ($span != 3)
  672.         {
  673.         Parse::RecDescent::_error(
  674.             "Incorrect <$op->{type}op:...> specification:
  675.              expected 3 args, but found $span instead", $line);
  676.         Parse::RecDescent::_hint(
  677.             "The <$op->{type}op:...> directive requires a
  678.              sequence of exactly three elements. For example:
  679.                  <$op->{type}op:leftarg /op/ rightarg>");
  680.         }
  681.         else
  682.         {
  683.         push @{$self->{items}},
  684.             Parse::RecDescent::Operator->new(
  685.                 $op->{type}, $minrep, $maxrep, splice(@{$self->{"items"}}, -3));
  686.         $self->{items}[-1]->sethashname($self);
  687.         $self->{items}[-1]{name} = $op->{name};
  688.         }
  689.     }
  690. }
  691.  
  692. sub prevwasreturn
  693. {
  694.     my ( $self, $line ) = @_;
  695.     unless (@{$self->{items}})
  696.     {
  697.         Parse::RecDescent::_error(
  698.             "Incorrect <return:...> specification:
  699.             expected item missing", $line);
  700.         Parse::RecDescent::_hint(
  701.             "The <return:...> directive requires a
  702.             sequence of at least one item. For example:
  703.                 <return: list>");
  704.         return;
  705.     }
  706.     push @{$self->{items}},
  707.         Parse::RecDescent::Result->new();
  708. }
  709.  
  710. sub additem
  711. {
  712.     my ( $self, $item ) = @_;
  713.     $item->sethashname($self);
  714.     push @{$self->{"items"}}, $item;
  715.     return $item;
  716. }
  717.  
  718.  
  719. sub preitempos
  720. {
  721.     return q
  722.     {
  723.         push @itempos, {'offset' => {'from'=>$thisoffset, 'to'=>undef},
  724.                 'line'   => {'from'=>$thisline,   'to'=>undef},
  725.                 'column' => {'from'=>$thiscolumn, 'to'=>undef} };
  726.     }
  727. }
  728.  
  729. sub incitempos
  730. {
  731.     return q
  732.     {
  733.         $itempos[$#itempos]{'offset'}{'from'} += length($1);
  734.         $itempos[$#itempos]{'line'}{'from'}   = $thisline;
  735.         $itempos[$#itempos]{'column'}{'from'} = $thiscolumn;
  736.     }
  737. }
  738.  
  739. sub postitempos
  740. {
  741.     return q
  742.     {
  743.         $itempos[$#itempos]{'offset'}{'to'} = $prevoffset;
  744.         $itempos[$#itempos]{'line'}{'to'}   = $prevline;
  745.         $itempos[$#itempos]{'column'}{'to'} = $prevcolumn;
  746.     }
  747. }
  748.  
  749. sub code($$$$)
  750. {
  751.     my ($self,$namespace,$rule,$parser) = @_;
  752.     my $code =
  753. '
  754.     while (!$_matched'
  755.     . (defined $self->{"uncommit"} ? '' : ' && !$commit')
  756.     . ')
  757.     {
  758.         ' .
  759.         ($self->changesskip()
  760.             ? 'local $skip = defined($skip) ? $skip : $Parse::RecDescent::skip;'
  761.             : '') .'
  762.         Parse::RecDescent::_trace(q{Trying production: ['
  763.                       . $self->describe . ']},
  764.                       Parse::RecDescent::_tracefirst($_[1]),
  765.                       q{' . $rule ->{name}. '},
  766.                       $tracelevel)
  767.                         if defined $::RD_TRACE;
  768.         my $thisprod = $thisrule->{"prods"}[' . $self->{"number"} . '];
  769.         ' . (defined $self->{"error"} ? '' : '$text = $_[1];' ) . '
  770.         my $_savetext;
  771.         @item = (q{' . $rule->{"name"} . '});
  772.         %item = (__RULE__ => q{' . $rule->{"name"} . '});
  773.         my $repcount = 0;
  774.  
  775. ';
  776.     $code .= 
  777. '        my @itempos = ({});
  778. '            if $parser->{_check}{itempos};
  779.  
  780.     my $item;
  781.     my $i;
  782.  
  783.     for ($i = 0; $i < @{$self->{"items"}}; $i++)
  784.     {
  785.         $item = ${$self->{items}}[$i];
  786.  
  787.         $code .= preitempos() if $parser->{_check}{itempos};
  788.  
  789.         $code .= $item->code($namespace,$rule,$parser->{_check});
  790.  
  791.         $code .= postitempos() if $parser->{_check}{itempos};
  792.  
  793.     }
  794.  
  795.     if ($parser->{_AUTOACTION} && defined($item) && !$item->isa("Parse::RecDescent::Action"))
  796.     {
  797.         $code .= $parser->{_AUTOACTION}->code($namespace,$rule);
  798.         Parse::RecDescent::_warn(1,"Autogenerating action in rule
  799.                        \"$rule->{name}\":
  800.                         $parser->{_AUTOACTION}{code}")
  801.         and
  802.         Parse::RecDescent::_hint("The \$::RD_AUTOACTION was defined,
  803.                       so any production not ending in an
  804.                       explicit action has the specified
  805.                              \"auto-action\" automatically
  806.                       appended.");
  807.     }
  808.     elsif ($parser->{_AUTOTREE} && defined($item) && !$item->isa("Parse::RecDescent::Action"))
  809.     {
  810.         if ($i==1 && $item->isterminal)
  811.         {
  812.             $code .= $parser->{_AUTOTREE}{TERMINAL}->code($namespace,$rule);
  813.         }
  814.         else
  815.         {
  816.             $code .= $parser->{_AUTOTREE}{NODE}->code($namespace,$rule);
  817.         }
  818.         Parse::RecDescent::_warn(1,"Autogenerating tree-building action in rule
  819.                        \"$rule->{name}\"")
  820.         and
  821.         Parse::RecDescent::_hint("The directive <autotree> was specified,
  822.                                           so any production not ending
  823.                                           in an explicit action has
  824.                                           some parse-tree building code
  825.                                           automatically appended.");
  826.     }
  827.  
  828.     $code .= 
  829. '
  830.  
  831.         Parse::RecDescent::_trace(q{>>Matched production: ['
  832.                       . $self->describe . ']<<},
  833.                       Parse::RecDescent::_tracefirst($text),
  834.                       q{' . $rule->{name} . '},
  835.                       $tracelevel)
  836.                         if defined $::RD_TRACE;
  837.         $_matched = 1;
  838.         last;
  839.     }
  840.  
  841. ';
  842.     return $code;
  843. }
  844.  
  845. 1;
  846.  
  847. package Parse::RecDescent::Action;
  848.  
  849. sub describe { undef }
  850.  
  851. sub sethashname { $_[0]->{hashname} = '__ACTION' . ++$_[1]->{actcount} .'__'; }
  852.  
  853. sub new
  854. {
  855.     my $class = ref($_[0]) || $_[0];
  856.     bless 
  857.     {
  858.         "code"      => $_[1],
  859.         "lookahead" => $_[2],
  860.         "line"      => $_[3],
  861.     }, $class;
  862. }
  863.  
  864. sub issubrule { undef }
  865. sub isterminal { 0 }
  866.  
  867. sub code($$$$)
  868. {
  869.     my ($self, $namespace, $rule) = @_;
  870.     
  871. '
  872.         Parse::RecDescent::_trace(q{Trying action},
  873.                       Parse::RecDescent::_tracefirst($text),
  874.                       q{' . $rule->{name} . '},
  875.                       $tracelevel)
  876.                         if defined $::RD_TRACE;
  877.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
  878.  
  879.         $_tok = ($_noactions) ? 0 : do ' . $self->{"code"} . ';
  880.         ' . ($self->{"lookahead"}<0?'if':'unless') . ' (defined $_tok)
  881.         {
  882.             Parse::RecDescent::_trace(q{<<Didn\'t match action>> (return value: [undef])})
  883.                     if defined $::RD_TRACE;
  884.             last;
  885.         }
  886.         Parse::RecDescent::_trace(q{>>Matched action<< (return value: [}
  887.                       . $_tok . q{])},
  888.                       Parse::RecDescent::_tracefirst($text))
  889.                         if defined $::RD_TRACE;
  890.         push @item, $_tok;
  891.         ' . ($self->{line}>=0 ? '$item{'. $self->{hashname} .'}=$_tok;' : '' ) .'
  892.         ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
  893. '
  894. }
  895.  
  896.  
  897. 1;
  898.  
  899. package Parse::RecDescent::Directive;
  900.  
  901. sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} .  '__'; }
  902.  
  903. sub issubrule { undef }
  904. sub isterminal { 0 }
  905. sub describe { $_[1] ? '' : $_[0]->{name} } 
  906.  
  907. sub new ($$$$$)
  908. {
  909.     my $class = ref($_[0]) || $_[0];
  910.     bless 
  911.     {
  912.         "code"      => $_[1],
  913.         "lookahead" => $_[2],
  914.         "line"      => $_[3],
  915.         "name"      => $_[4],
  916.     }, $class;
  917. }
  918.  
  919. sub code($$$$)
  920. {
  921.     my ($self, $namespace, $rule) = @_;
  922.     
  923. '
  924.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
  925.  
  926.         Parse::RecDescent::_trace(q{Trying directive: ['
  927.                     . $self->describe . ']},
  928.                     Parse::RecDescent::_tracefirst($text),
  929.                       q{' . $rule->{name} . '},
  930.                       $tracelevel)
  931.                         if defined $::RD_TRACE; ' .'
  932.         $_tok = do { ' . $self->{"code"} . ' };
  933.         if (defined($_tok))
  934.         {
  935.             Parse::RecDescent::_trace(q{>>Matched directive<< (return value: [}
  936.                         . $_tok . q{])},
  937.                         Parse::RecDescent::_tracefirst($text))
  938.                             if defined $::RD_TRACE;
  939.         }
  940.         else
  941.         {
  942.             Parse::RecDescent::_trace(q{<<Didn\'t match directive>>},
  943.                         Parse::RecDescent::_tracefirst($text))
  944.                             if defined $::RD_TRACE;
  945.         }
  946.         ' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
  947.         last '
  948.         . ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
  949.         push @item, $item{'.$self->{hashname}.'}=$_tok;
  950.         ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
  951. '
  952. }
  953.  
  954. 1;
  955.  
  956. package Parse::RecDescent::UncondReject;
  957.  
  958. sub issubrule { undef }
  959. sub isterminal { 0 }
  960. sub describe { $_[1] ? '' : $_[0]->{name} }
  961. sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} .  '__'; }
  962.  
  963. sub new ($$$;$)
  964. {
  965.     my $class = ref($_[0]) || $_[0];
  966.     bless 
  967.     {
  968.         "lookahead" => $_[1],
  969.         "line"      => $_[2],
  970.         "name"      => $_[3],
  971.     }, $class;
  972. }
  973.  
  974. # MARK, YOU MAY WANT TO OPTIMIZE THIS.
  975.  
  976.  
  977. sub code($$$$)
  978. {
  979.     my ($self, $namespace, $rule) = @_;
  980.     
  981. '
  982.         Parse::RecDescent::_trace(q{>>Rejecting production<< (found '
  983.                      . $self->describe . ')},
  984.                      Parse::RecDescent::_tracefirst($text),
  985.                       q{' . $rule->{name} . '},
  986.                       $tracelevel)
  987.                         if defined $::RD_TRACE;
  988.         undef $return;
  989.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
  990.  
  991.         $_tok = undef;
  992.         ' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
  993.         last '
  994.         . ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
  995. '
  996. }
  997.  
  998. 1;
  999.  
  1000. package Parse::RecDescent::Error;
  1001.  
  1002. sub issubrule { undef }
  1003. sub isterminal { 0 }
  1004. sub describe { $_[1] ? '' : $_[0]->{commitonly} ? '<error?:...>' : '<error...>' }
  1005. sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} .  '__'; }
  1006.  
  1007. sub new ($$$$$)
  1008. {
  1009.     my $class = ref($_[0]) || $_[0];
  1010.     bless 
  1011.     {
  1012.         "msg"        => $_[1],
  1013.         "lookahead"  => $_[2],
  1014.         "commitonly" => $_[3],
  1015.         "line"       => $_[4],
  1016.     }, $class;
  1017. }
  1018.  
  1019. sub code($$$$)
  1020. {
  1021.     my ($self, $namespace, $rule) = @_;
  1022.     
  1023.     my $action = '';
  1024.     
  1025.     if ($self->{"msg"})  # ERROR MESSAGE SUPPLIED
  1026.     {
  1027.         #WAS: $action .= "Parse::RecDescent::_error(qq{$self->{msg}}" .  ',$thisline);'; 
  1028.         $action .= 'push @{$thisparser->{errors}}, [qq{'.$self->{msg}.'},$thisline];'; 
  1029.  
  1030.     }
  1031.     else      # GENERATE ERROR MESSAGE DURING PARSE
  1032.     {
  1033.         $action .= '
  1034.         my $rule = $item[0];
  1035.            $rule =~ s/_/ /g;
  1036.         #WAS: Parse::RecDescent::_error("Invalid $rule: " . $expectation->message() ,$thisline);
  1037.         push @{$thisparser->{errors}}, ["Invalid $rule: " . $expectation->message() ,$thisline];
  1038.         '; 
  1039.     }
  1040.  
  1041.     my $dir =
  1042.           new Parse::RecDescent::Directive('if (' .
  1043.         ($self->{"commitonly"} ? '$commit' : '1') . 
  1044.         ") { do {$action} unless ".' $_noactions; undef } else {0}',
  1045.                         $self->{"lookahead"},0,$self->describe); 
  1046.     $dir->{hashname} = $self->{hashname};
  1047.     return $dir->code($namespace, $rule, 0);
  1048. }
  1049.  
  1050. 1;
  1051.  
  1052. package Parse::RecDescent::Token;
  1053.  
  1054. sub sethashname { $_[0]->{hashname} = '__PATTERN' . ++$_[1]->{patcount} . '__'; }
  1055.  
  1056. sub issubrule { undef }
  1057. sub isterminal { 1 }
  1058. sub describe ($) { shift->{'description'}}
  1059.  
  1060.  
  1061. # ARGS ARE: $self, $pattern, $left_delim, $modifiers, $lookahead, $linenum
  1062. sub new ($$$$$$)
  1063. {
  1064.     my $class = ref($_[0]) || $_[0];
  1065.     my $pattern = $_[1];
  1066.     my $pat = $_[1];
  1067.     my $ldel = $_[2];
  1068.     my $rdel = $ldel;
  1069.     $rdel =~ tr/{[(</}])>/;
  1070.  
  1071.     my $mod = $_[3];
  1072.  
  1073.     my $desc;
  1074.  
  1075.     if ($ldel eq '/') { $desc = "$ldel$pattern$rdel$mod" }
  1076.     else          { $desc = "m$ldel$pattern$rdel$mod" }
  1077.     $desc =~ s/\\/\\\\/g;
  1078.     $desc =~ s/\$$/\\\$/g;
  1079.     $desc =~ s/}/\\}/g;
  1080.     $desc =~ s/{/\\{/g;
  1081.  
  1082.     if (!eval "no strict;
  1083.            local \$SIG{__WARN__} = sub {0};
  1084.            '' =~ m$ldel$pattern$rdel" and $@)
  1085.     {
  1086.         Parse::RecDescent::_warn(3, "Token pattern \"m$ldel$pattern$rdel\"
  1087.                          may not be a valid regular expression",
  1088.                        $_[5]);
  1089.         $@ =~ s/ at \(eval.*/./;
  1090.         Parse::RecDescent::_hint($@);
  1091.     }
  1092.  
  1093.     # QUIETLY PREVENT (WELL-INTENTIONED) CALAMITY
  1094.     $mod =~ s/[gc]//g;
  1095.     $pattern =~ s/(\A|[^\\])\\G/$1/g;
  1096.  
  1097.     bless 
  1098.     {
  1099.         "pattern"   => $pattern,
  1100.         "ldelim"      => $ldel,
  1101.         "rdelim"      => $rdel,
  1102.         "mod"         => $mod,
  1103.         "lookahead"   => $_[4],
  1104.         "line"        => $_[5],
  1105.         "description" => $desc,
  1106.     }, $class;
  1107. }
  1108.  
  1109.  
  1110. sub code($$$$)
  1111. {
  1112.     my ($self, $namespace, $rule, $check) = @_;
  1113.     my $ldel = $self->{"ldelim"};
  1114.     my $rdel = $self->{"rdelim"};
  1115.     my $sdel = $ldel;
  1116.     my $mod  = $self->{"mod"};
  1117.  
  1118.     $sdel =~ s/[[{(<]/{}/;
  1119.     
  1120. my $code = '
  1121.         Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe
  1122.                       . ']}, Parse::RecDescent::_tracefirst($text),
  1123.                       q{' . $rule->{name} . '},
  1124.                       $tracelevel)
  1125.                         if defined $::RD_TRACE;
  1126.         $lastsep = "";
  1127.         $expectation->is(q{' . ($rule->hasleftmost($self) ? ''
  1128.                 : $self->describe ) . '})->at($text);
  1129.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . '
  1130.  
  1131.         ' . ($self->{"lookahead"}<0?'if':'unless')
  1132.         . ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and '
  1133.         . ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '')
  1134.         . '  $text =~ s' . $ldel . '\A(?:' . $self->{"pattern"} . ')'
  1135.                  . $rdel . $sdel . $mod . ')
  1136.         {
  1137.             '.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
  1138.             $expectation->failed();
  1139.             Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>},
  1140.                           Parse::RecDescent::_tracefirst($text))
  1141.                     if defined $::RD_TRACE;
  1142.  
  1143.             last;
  1144.         }
  1145.         Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
  1146.                         . $& . q{])},
  1147.                           Parse::RecDescent::_tracefirst($text))
  1148.                     if defined $::RD_TRACE;
  1149.         push @item, $item{'.$self->{hashname}.'}=$&;
  1150.         ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
  1151. ';
  1152.  
  1153.     return $code;
  1154. }
  1155.  
  1156. 1;
  1157.  
  1158. package Parse::RecDescent::Literal;
  1159.  
  1160. sub sethashname { $_[0]->{hashname} = '__STRING' . ++$_[1]->{strcount} . '__'; }
  1161.  
  1162. sub issubrule { undef }
  1163. sub isterminal { 1 }
  1164. sub describe ($) { shift->{'description'} }
  1165.  
  1166. sub new ($$$$)
  1167. {
  1168.     my $class = ref($_[0]) || $_[0];
  1169.  
  1170.     my $pattern = $_[1];
  1171.  
  1172.     my $desc = $pattern;
  1173.     $desc=~s/\\/\\\\/g;
  1174.     $desc=~s/}/\\}/g;
  1175.     $desc=~s/{/\\{/g;
  1176.  
  1177.     bless 
  1178.     {
  1179.         "pattern"     => $pattern,
  1180.         "lookahead"   => $_[2],
  1181.         "line"        => $_[3],
  1182.         "description" => "'$desc'",
  1183.     }, $class;
  1184. }
  1185.  
  1186.  
  1187. sub code($$$$)
  1188. {
  1189.     my ($self, $namespace, $rule, $check) = @_;
  1190.     
  1191. my $code = '
  1192.         Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe
  1193.                       . ']},
  1194.                       Parse::RecDescent::_tracefirst($text),
  1195.                       q{' . $rule->{name} . '},
  1196.                       $tracelevel)
  1197.                         if defined $::RD_TRACE;
  1198.         $lastsep = "";
  1199.         $expectation->is(q{' . ($rule->hasleftmost($self) ? ''
  1200.                 : $self->describe ) . '})->at($text);
  1201.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . '
  1202.  
  1203.         ' . ($self->{"lookahead"}<0?'if':'unless')
  1204.         . ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and '
  1205.         . ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '')
  1206.         . '  $text =~ s/\A' . quotemeta($self->{"pattern"}) . '//)
  1207.         {
  1208.             '.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
  1209.             $expectation->failed();
  1210.             Parse::RecDescent::_trace(qq{<<Didn\'t match terminal>>},
  1211.                           Parse::RecDescent::_tracefirst($text))
  1212.                             if defined $::RD_TRACE;
  1213.             last;
  1214.         }
  1215.         Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
  1216.                         . $& . q{])},
  1217.                           Parse::RecDescent::_tracefirst($text))
  1218.                             if defined $::RD_TRACE;
  1219.         push @item, $item{'.$self->{hashname}.'}=$&;
  1220.         ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
  1221. ';
  1222.  
  1223.     return $code;
  1224. }
  1225.  
  1226. 1;
  1227.  
  1228. package Parse::RecDescent::InterpLit;
  1229.  
  1230. sub sethashname { $_[0]->{hashname} = '__STRING' . ++$_[1]->{strcount} . '__'; }
  1231.  
  1232. sub issubrule { undef }
  1233. sub isterminal { 1 }
  1234. sub describe ($) { shift->{'description'} }
  1235.  
  1236. sub new ($$$$)
  1237. {
  1238.     my $class = ref($_[0]) || $_[0];
  1239.  
  1240.     my $pattern = $_[1];
  1241.     $pattern =~ s#/#\\/#g;
  1242.  
  1243.     my $desc = $pattern;
  1244.     $desc=~s/\\/\\\\/g;
  1245.     $desc=~s/}/\\}/g;
  1246.     $desc=~s/{/\\{/g;
  1247.  
  1248.     bless 
  1249.     {
  1250.         "pattern"   => $pattern,
  1251.         "lookahead" => $_[2],
  1252.         "line"      => $_[3],
  1253.         "description" => "'$desc'",
  1254.     }, $class;
  1255. }
  1256.  
  1257. sub code($$$$)
  1258. {
  1259.     my ($self, $namespace, $rule, $check) = @_;
  1260.     
  1261. my $code = '
  1262.         Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe
  1263.                       . ']},
  1264.                       Parse::RecDescent::_tracefirst($text),
  1265.                       q{' . $rule->{name} . '},
  1266.                       $tracelevel)
  1267.                         if defined $::RD_TRACE;
  1268.         $lastsep = "";
  1269.         $expectation->is(q{' . ($rule->hasleftmost($self) ? ''
  1270.                 : $self->describe ) . '})->at($text);
  1271.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . '
  1272.  
  1273.         ' . ($self->{"lookahead"}<0?'if':'unless')
  1274.         . ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and '
  1275.         . ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '')
  1276.         . '  do { $_tok = "' . $self->{"pattern"} . '"; 1 } and
  1277.              substr($text,0,length($_tok)) eq $_tok and
  1278.              do { substr($text,0,length($_tok)) = ""; 1; }
  1279.         )
  1280.         {
  1281.             '.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
  1282.             $expectation->failed();
  1283.             Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>},
  1284.                           Parse::RecDescent::_tracefirst($text))
  1285.                             if defined $::RD_TRACE;
  1286.             last;
  1287.         }
  1288.         Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [}
  1289.                         . $_tok . q{])},
  1290.                           Parse::RecDescent::_tracefirst($text))
  1291.                             if defined $::RD_TRACE;
  1292.         push @item, $item{'.$self->{hashname}.'}=$_tok;
  1293.         ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
  1294. ';
  1295.  
  1296.     return $code;
  1297. }
  1298.  
  1299. 1;
  1300.  
  1301. package Parse::RecDescent::Subrule;
  1302.  
  1303. sub issubrule ($) { return $_[0]->{"subrule"} }
  1304. sub isterminal { 0 }
  1305. sub sethashname {}
  1306.  
  1307. sub describe ($)
  1308. {
  1309.     my $desc = $_[0]->{"implicit"} || $_[0]->{"subrule"};
  1310.     $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
  1311.     return $desc;
  1312. }
  1313.  
  1314. sub callsyntax($$)
  1315. {
  1316.     if ($_[0]->{"matchrule"})
  1317.     {
  1318.         return "&{'$_[1]'.qq{$_[0]->{subrule}}}";
  1319.     }
  1320.     else
  1321.     {
  1322.         return $_[1].$_[0]->{"subrule"};
  1323.     }
  1324. }
  1325.  
  1326. sub new ($$$$;$$$)
  1327. {
  1328.     my $class = ref($_[0]) || $_[0];
  1329.     bless 
  1330.     {
  1331.         "subrule"   => $_[1],
  1332.         "lookahead" => $_[2],
  1333.         "line"      => $_[3],
  1334.         "implicit"  => $_[4] || undef,
  1335.         "matchrule" => $_[5],
  1336.         "argcode"   => $_[6] || undef,
  1337.     }, $class;
  1338. }
  1339.  
  1340.  
  1341. sub code($$$$)
  1342. {
  1343.     my ($self, $namespace, $rule) = @_;
  1344.     
  1345. '
  1346.         Parse::RecDescent::_trace(q{Trying subrule: [' . $self->{"subrule"} . ']},
  1347.                   Parse::RecDescent::_tracefirst($text),
  1348.                   q{' . $rule->{"name"} . '},
  1349.                   $tracelevel)
  1350.                     if defined $::RD_TRACE;
  1351.         if (1) { no strict qw{refs};
  1352.         $expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
  1353.                 # WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
  1354.                 : 'q{'.$self->describe.'}' ) . ')->at($text);
  1355.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' )
  1356.         . ($self->{"lookahead"}<0?'if':'unless')
  1357.         . ' (defined ($_tok = '
  1358.         . $self->callsyntax($namespace.'::')
  1359.         . '($thisparser,$text,$repeating,'
  1360.         . ($self->{"lookahead"}?'1':'$_noactions')
  1361.         . ($self->{argcode} ? ",sub { return $self->{argcode} }"
  1362.                    : ',sub { \\@arg }')
  1363.         . ')))
  1364.         {
  1365.             '.($self->{"lookahead"} ? '$text = $_savetext;' : '').'
  1366.             Parse::RecDescent::_trace(q{<<Didn\'t match subrule: ['
  1367.             . $self->{subrule} . ']>>},
  1368.                           Parse::RecDescent::_tracefirst($text),
  1369.                           q{' . $rule->{"name"} .'},
  1370.                           $tracelevel)
  1371.                             if defined $::RD_TRACE;
  1372.             $expectation->failed();
  1373.             last;
  1374.         }
  1375.         Parse::RecDescent::_trace(q{>>Matched subrule: ['
  1376.                     . $self->{subrule} . ']<< (return value: [}
  1377.                     . $_tok . q{]},
  1378.                       
  1379.                       Parse::RecDescent::_tracefirst($text),
  1380.                       q{' . $rule->{"name"} .'},
  1381.                       $tracelevel)
  1382.                         if defined $::RD_TRACE;
  1383.         $item{q{' . $self->{subrule} . '}} = $_tok;
  1384.         push @item, $_tok;
  1385.         ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
  1386.         }
  1387. '
  1388. }
  1389.  
  1390. package Parse::RecDescent::Repetition;
  1391.  
  1392. sub issubrule ($) { return $_[0]->{"subrule"} }
  1393. sub isterminal { 0 }
  1394. sub sethashname {  }
  1395.  
  1396. sub describe ($)
  1397. {
  1398.     my $desc = $_[0]->{"expected"} || $_[0]->{"subrule"};
  1399.     $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
  1400.     return $desc;
  1401. }
  1402.  
  1403. sub callsyntax($$)
  1404. {
  1405.     if ($_[0]->{matchrule})
  1406.         { return "sub { goto &{''.qq{$_[1]$_[0]->{subrule}}} }"; }
  1407.     else
  1408.         { return "\\&$_[1]$_[0]->{subrule}"; }
  1409. }
  1410.  
  1411. sub new ($$$$$$$$$$)
  1412. {
  1413.     my ($self, $subrule, $repspec, $min, $max, $lookahead, $line, $parser, $matchrule, $argcode) = @_;
  1414.     my $class = ref($self) || $self;
  1415.     ($max, $min) = ( $min, $max) if ($max<$min);
  1416.  
  1417.     my $desc;
  1418.     if ($subrule=~/\A_alternation_\d+_of_production_\d+_of_rule/)
  1419.         { $desc = $parser->{"rules"}{$subrule}->expected }
  1420.  
  1421.     if ($lookahead)
  1422.     {
  1423.         if ($min>0)
  1424.         {
  1425.            return new Parse::RecDescent::Subrule($subrule,$lookahead,$line,$desc,$matchrule,$argcode);
  1426.         }
  1427.         else
  1428.         {
  1429.             Parse::RecDescent::_error("Not symbol (\"!\") before
  1430.                             \"$subrule\" doesn't make
  1431.                         sense.",$line);
  1432.             Parse::RecDescent::_hint("Lookahead for negated optional
  1433.                        repetitions (such as
  1434.                        \"!$subrule($repspec)\" can never
  1435.                        succeed, since optional items always
  1436.                        match (zero times at worst). 
  1437.                        Did you mean a single \"!$subrule\", 
  1438.                        instead?");
  1439.         }
  1440.     }
  1441.     bless 
  1442.     {
  1443.         "subrule"   => $subrule,
  1444.         "repspec"   => $repspec,
  1445.         "min"       => $min,
  1446.         "max"       => $max,
  1447.         "lookahead" => $lookahead,
  1448.         "line"      => $line,
  1449.         "expected"  => $desc,
  1450.         "argcode"   => $argcode || undef,
  1451.         "matchrule" => $matchrule,
  1452.     }, $class;
  1453. }
  1454.  
  1455. sub code($$$$)
  1456. {
  1457.     my ($self, $namespace, $rule) = @_;
  1458.     
  1459.     my ($subrule, $repspec, $min, $max, $lookahead) =
  1460.         @{$self}{ qw{subrule repspec min max lookahead} };
  1461.  
  1462. '
  1463.         Parse::RecDescent::_trace(q{Trying repeated subrule: [' . $self->describe . ']},
  1464.                   Parse::RecDescent::_tracefirst($text),
  1465.                   q{' . $rule->{"name"} . '},
  1466.                   $tracelevel)
  1467.                     if defined $::RD_TRACE;
  1468.         $expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
  1469.                 # WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
  1470.                 : 'q{'.$self->describe.'}' ) . ')->at($text);
  1471.         ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'
  1472.         unless (defined ($_tok = $thisparser->_parserepeat($text, '
  1473.         . $self->callsyntax($namespace.'::')
  1474.         . ', ' . $min . ', ' . $max . ', '
  1475.         . ($self->{"lookahead"}?'1':'$_noactions')
  1476.         . ',$expectation,'
  1477.         . ($self->{argcode} ? "sub { return $self->{argcode} }"
  1478.                    : 'undef')
  1479.         . '))) 
  1480.         {
  1481.             Parse::RecDescent::_trace(q{<<Didn\'t match repeated subrule: ['
  1482.             . $self->describe . ']>>},
  1483.                           Parse::RecDescent::_tracefirst($text),
  1484.                           q{' . $rule->{"name"} .'},
  1485.                           $tracelevel)
  1486.                             if defined $::RD_TRACE;
  1487.             last;
  1488.         }
  1489.         Parse::RecDescent::_trace(q{>>Matched repeated subrule: ['
  1490.                     . $self->{subrule} . ']<< (}
  1491.                     . @$_tok . q{ times)},
  1492.                       
  1493.                       Parse::RecDescent::_tracefirst($text),
  1494.                       q{' . $rule->{"name"} .'},
  1495.                       $tracelevel)
  1496.                         if defined $::RD_TRACE;
  1497.         $item{q{' . "$self->{subrule}($self->{repspec})" . '}} = $_tok;
  1498.         push @item, $_tok;
  1499.         ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
  1500.  
  1501. '
  1502. }
  1503.  
  1504. package Parse::RecDescent::Result;
  1505.  
  1506. sub issubrule { 0 }
  1507. sub isterminal { 0 }
  1508. sub describe { '' }
  1509.  
  1510. sub new
  1511. {
  1512.     my ($class, $pos) = @_;
  1513.  
  1514.     bless {}, $class;
  1515. }
  1516.  
  1517. sub code($$$$)
  1518. {
  1519.     my ($self, $namespace, $rule) = @_;
  1520.     
  1521.     '
  1522.         $return = $item[-1];
  1523.     ';
  1524. }
  1525.  
  1526. package Parse::RecDescent::Operator;
  1527.  
  1528. my @opertype = ( " non-optional", "n optional" );
  1529.  
  1530. sub issubrule { 0 }
  1531. sub isterminal { 0 }
  1532.  
  1533. sub describe { $_[0]->{"expected"} }
  1534. sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} .  '__'; }
  1535.  
  1536.  
  1537. sub new
  1538. {
  1539.     my ($class, $type, $minrep, $maxrep, $leftarg, $op, $rightarg) = @_;
  1540.  
  1541.     bless 
  1542.     {
  1543.         "type"      => "${type}op",
  1544.         "leftarg"   => $leftarg,
  1545.         "op"        => $op,
  1546.         "min"       => $minrep,
  1547.         "max"       => $maxrep,
  1548.         "rightarg"  => $rightarg,
  1549.         "expected"  => "<${type}op: ".$leftarg->describe." ".$op->describe." ".$rightarg->describe.">",
  1550.     }, $class;
  1551. }
  1552.  
  1553. sub code($$$$)
  1554. {
  1555.     my ($self, $namespace, $rule) = @_;
  1556.     
  1557.     my ($leftarg, $op, $rightarg) =
  1558.         @{$self}{ qw{leftarg op rightarg} };
  1559.  
  1560.     my $code = '
  1561.         Parse::RecDescent::_trace(q{Trying operator: [' . $self->describe . ']},
  1562.                   Parse::RecDescent::_tracefirst($text),
  1563.                   q{' . $rule->{"name"} . '},
  1564.                   $tracelevel)
  1565.                     if defined $::RD_TRACE;
  1566.         $expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
  1567.                 # WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
  1568.                 : 'q{'.$self->describe.'}' ) . ')->at($text);
  1569.  
  1570.         $_tok = undef;
  1571.         OPLOOP: while (1)
  1572.         {
  1573.           $repcount = 0;
  1574.           my  @item;
  1575.           ';
  1576.  
  1577.     if ($self->{type} eq "leftop" )
  1578.     {
  1579.         $code .= '
  1580.           # MATCH LEFTARG
  1581.           ' . $leftarg->code(@_[1..2]) . '
  1582.  
  1583.           $repcount++;
  1584.  
  1585.           my $savetext = $text;
  1586.           my $backtrack;
  1587.  
  1588.           # MATCH (OP RIGHTARG)(s)
  1589.           while ($repcount < ' . $self->{max} . ')
  1590.           {
  1591.             $backtrack = 0;
  1592.             ' . $op->code(@_[1..2]) . '
  1593.             ' . ($op->isterminal() ? 'pop @item;' : '$backtrack=1;' ) . '
  1594.             ' . (ref($op) eq 'Parse::RecDescent::Token'
  1595.                 ? 'if (defined $1) {push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; $backtrack=1;}'
  1596.                 : "" ) . '
  1597.             ' . $rightarg->code(@_[1..2]) . '
  1598.             $savetext = $text;
  1599.             $repcount++;
  1600.           }
  1601.           $text = $savetext;
  1602.           pop @item if $backtrack;
  1603.  
  1604.           ';
  1605.     }
  1606.     else
  1607.     {
  1608.         $code .= '
  1609.           my $savetext = $text;
  1610.           my $backtrack;
  1611.           # MATCH (LEFTARG OP)(s)
  1612.           while ($repcount < ' . $self->{max} . ')
  1613.           {
  1614.             $backtrack = 0;
  1615.             ' . $leftarg->code(@_[1..2]) . '
  1616.             $repcount++;
  1617.             $backtrack = 1;
  1618.             ' . $op->code(@_[1..2]) . '
  1619.             $savetext = $text;
  1620.             ' . ($op->isterminal() ? 'pop @item;' : "" ) . '
  1621.             ' . (ref($op) eq 'Parse::RecDescent::Token' ? 'do { push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; } if defined $1;' : "" ) . '
  1622.           }
  1623.           $text = $savetext;
  1624.           pop @item if $backtrack;
  1625.  
  1626.           # MATCH RIGHTARG
  1627.           ' . $rightarg->code(@_[1..2]) . '
  1628.           $repcount++;
  1629.           ';
  1630.     }
  1631.  
  1632.     $code .= 'unless (@item) { undef $_tok; last }' unless $self->{min}==0;
  1633.  
  1634.     $code .= '
  1635.           $_tok = [ @item ];
  1636.           last;
  1637.         } 
  1638.  
  1639.         unless ($repcount>='.$self->{min}.')
  1640.         {
  1641.             Parse::RecDescent::_trace(q{<<Didn\'t match operator: ['
  1642.                           . $self->describe
  1643.                           . ']>>},
  1644.                           Parse::RecDescent::_tracefirst($text),
  1645.                           q{' . $rule->{"name"} .'},
  1646.                           $tracelevel)
  1647.                             if defined $::RD_TRACE;
  1648.             $expectation->failed();
  1649.             last;
  1650.         }
  1651.         Parse::RecDescent::_trace(q{>>Matched operator: ['
  1652.                       . $self->describe
  1653.                       . ']<< (return value: [}
  1654.                       . qq{@{$_tok||[]}} . q{]},
  1655.                       Parse::RecDescent::_tracefirst($text),
  1656.                       q{' . $rule->{"name"} .'},
  1657.                       $tracelevel)
  1658.                         if defined $::RD_TRACE;
  1659.  
  1660.         push @item, $item{'.($self->{name}||$self->{hashname}).'}=$_tok||[];
  1661.  
  1662. ';
  1663.     return $code;
  1664. }
  1665.  
  1666.  
  1667. package Parse::RecDescent::Expectation;
  1668.  
  1669. sub new ($)
  1670. {
  1671.     bless {
  1672.         "failed"      => 0,
  1673.         "expected"      => "",
  1674.         "unexpected"      => "",
  1675.         "lastexpected"      => "",
  1676.         "lastunexpected"  => "",
  1677.         "defexpected"      => $_[1],
  1678.           };
  1679. }
  1680.  
  1681. sub is ($$)
  1682. {
  1683.     $_[0]->{lastexpected} = $_[1]; return $_[0];
  1684. }
  1685.  
  1686. sub at ($$)
  1687. {
  1688.     $_[0]->{lastunexpected} = $_[1]; return $_[0];
  1689. }
  1690.  
  1691. sub failed ($)
  1692. {
  1693.     return unless $_[0]->{lastexpected};
  1694.     $_[0]->{expected}   = $_[0]->{lastexpected}   unless $_[0]->{failed};
  1695.     $_[0]->{unexpected} = $_[0]->{lastunexpected} unless $_[0]->{failed};
  1696.     $_[0]->{failed} = 1;
  1697. }
  1698.  
  1699. sub message ($)
  1700. {
  1701.     my ($self) = @_;
  1702.     $self->{expected} = $self->{defexpected} unless $self->{expected};
  1703.     $self->{expected} =~ s/_/ /g;
  1704.     if (!$self->{unexpected} || $self->{unexpected} =~ /\A\s*\Z/s)
  1705.     {
  1706.         return "Was expecting $self->{expected}";
  1707.     }
  1708.     else
  1709.     {
  1710.         $self->{unexpected} =~ /\s*(.*)/;
  1711.         return "Was expecting $self->{expected} but found \"$1\" instead";
  1712.     }
  1713. }
  1714.  
  1715. 1;
  1716.  
  1717. package Parse::RecDescent;
  1718.  
  1719. use Carp;
  1720. use vars qw ( $AUTOLOAD $VERSION );
  1721.  
  1722. my $ERRORS = 0;
  1723.  
  1724. $VERSION = '1.94';
  1725.  
  1726. # BUILDING A PARSER
  1727.  
  1728. my $nextnamespace = "namespace000001";
  1729.  
  1730. sub _nextnamespace()
  1731. {
  1732.     return "Parse::RecDescent::" . $nextnamespace++;
  1733. }
  1734.  
  1735. sub new ($$$)
  1736. {
  1737.     my $class = ref($_[0]) || $_[0];
  1738.         local $Parse::RecDescent::compiling = $_[2];
  1739.         my $name_space_name = defined $_[3]
  1740.         ? "Parse::RecDescent::".$_[3] 
  1741.         : _nextnamespace();
  1742.     my $self =
  1743.     {
  1744.         "rules"     => {},
  1745.         "namespace" => $name_space_name,
  1746.         "startcode" => '',
  1747.         "localvars" => '',
  1748.         "_AUTOACTION" => undef,
  1749.         "_AUTOTREE"   => undef,
  1750.     };
  1751.     if ($::RD_AUTOACTION)
  1752.     {
  1753.         my $sourcecode = $::RD_AUTOACTION;
  1754.         $sourcecode = "{ $sourcecode }"
  1755.             unless $sourcecode =~ /\A\s*\{.*\}\s*\Z/;
  1756.         $self->{_check}{itempos} =
  1757.             $sourcecode =~ /\@itempos\b|\$itempos\s*\[/;
  1758.         $self->{_AUTOACTION}
  1759.             = new Parse::RecDescent::Action($sourcecode,0,-1)
  1760.     }
  1761.     
  1762.     bless $self, $class;
  1763.     shift;
  1764.     return $self->Replace(@_)
  1765. }
  1766.  
  1767. sub Compile($$$$) {
  1768.  
  1769.     die "Compilation of Parse::RecDescent grammars not yet implemented\n";
  1770. }
  1771.  
  1772. sub DESTROY {}  # SO AUTOLOADER IGNORES IT
  1773.  
  1774. # BUILDING A GRAMMAR....
  1775.  
  1776. sub Replace ($$)
  1777. {
  1778.     splice(@_, 2, 0, 1);
  1779.     return _generate(@_);
  1780. }
  1781.  
  1782. sub Extend ($$)
  1783. {
  1784.     splice(@_, 2, 0, 0);
  1785.     return _generate(@_);
  1786. }
  1787.  
  1788. sub _no_rule ($$;$)
  1789. {
  1790.     _error("Ruleless $_[0] at start of grammar.",$_[1]);
  1791.     my $desc = $_[2] ? "\"$_[2]\"" : "";
  1792.     _hint("You need to define a rule for the $_[0] $desc
  1793.            to be part of.");
  1794. }
  1795.  
  1796. my $NEGLOOKAHEAD    = '\G(\s*\.\.\.\!)';
  1797. my $POSLOOKAHEAD    = '\G(\s*\.\.\.)';
  1798. my $RULE        = '\G\s*(\w+)[ \t]*:';
  1799. my $PROD        = '\G\s*([|])';
  1800. my $TOKEN        = q{\G\s*/((\\\\/|[^/])*)/([cgimsox]*)};
  1801. my $MTOKEN        = q{\G\s*(m\s*[^\w\s])};
  1802. my $LITERAL        = q{\G\s*'((\\\\['\\\\]|[^'])*)'};
  1803. my $INTERPLIT        = q{\G\s*"((\\\\["\\\\]|[^"])*)"};
  1804. my $SUBRULE        = '\G\s*(\w+)';
  1805. my $MATCHRULE        = '\G(\s*<matchrule:)';
  1806. my $SIMPLEPAT        = '((\\s+/[^/\\\\]*(?:\\\\.[^/\\\\]*)*/)?)';
  1807. my $OPTIONAL        = '\G\((\?)'.$SIMPLEPAT.'\)';
  1808. my $ANY            = '\G\((s\?)'.$SIMPLEPAT.'\)';
  1809. my $MANY         = '\G\((s|\.\.)'.$SIMPLEPAT.'\)';
  1810. my $EXACTLY        = '\G\(([1-9]\d*)'.$SIMPLEPAT.'\)';
  1811. my $BETWEEN        = '\G\((\d+)\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
  1812. my $ATLEAST        = '\G\((\d+)\.\.'.$SIMPLEPAT.'\)';
  1813. my $ATMOST        = '\G\(\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
  1814. my $BADREP        = '\G\((-?\d+)?\.\.(-?\d+)?'.$SIMPLEPAT.'\)';
  1815. my $ACTION        = '\G\s*\{';
  1816. my $IMPLICITSUBRULE    = '\G\s*\(';
  1817. my $COMMENT        = '\G\s*(#.*)';
  1818. my $COMMITMK        = '\G\s*<commit>';
  1819. my $UNCOMMITMK        = '\G\s*<uncommit>';
  1820. my $QUOTELIKEMK        = '\G\s*<perl_quotelike>';
  1821. my $CODEBLOCKMK        = '\G\s*<perl_codeblock(?:\s+([][()<>{}]+))?>';
  1822. my $VARIABLEMK        = '\G\s*<perl_variable>';
  1823. my $NOCHECKMK        = '\G\s*<nocheck>';
  1824. my $AUTOTREEMK        = '\G\s*<autotree>';
  1825. my $AUTOSTUBMK        = '\G\s*<autostub>';
  1826. my $AUTORULEMK        = '\G\s*<autorule:(.*?)>';
  1827. my $REJECTMK        = '\G\s*<reject>';
  1828. my $CONDREJECTMK    = '\G\s*<reject:';
  1829. my $SCOREMK        = '\G\s*<score:';
  1830. my $AUTOSCOREMK        = '\G\s*<autoscore:';
  1831. my $SKIPMK        = '\G\s*<skip:';
  1832. my $OPMK        = '\G\s*<(left|right)op(?:=(\'.*?\'))?:';
  1833. my $ENDDIRECTIVEMK    = '\G\s*>';
  1834. my $RESYNCMK        = '\G\s*<resync>';
  1835. my $RESYNCPATMK        = '\G\s*<resync:';
  1836. my $RULEVARPATMK    = '\G\s*<rulevar:';
  1837. my $DEFERPATMK        = '\G\s*<defer:';
  1838. my $TOKENPATMK        = '\G\s*<token:';
  1839. my $AUTOERRORMK        = '\G\s*<error(\??)>';
  1840. my $MSGERRORMK        = '\G\s*<error(\??):';
  1841. my $UNCOMMITPROD    = $PROD.'\s*<uncommit';
  1842. my $ERRORPROD        = $PROD.'\s*<error';
  1843. my $LONECOLON        = '\G\s*:';
  1844. my $OTHER        = '\G\s*([^\s]+)';
  1845.  
  1846. my $lines = 0;
  1847.  
  1848. sub _generate($$$;$$)
  1849. {
  1850.     my ($self, $grammar, $replace, $isimplicit, $isleftop) = (@_, 0);
  1851.  
  1852.     my $aftererror = 0;
  1853.     my $lookahead = 0;
  1854.     my $lookaheadspec = "";
  1855.     $lines = _linecount($grammar) unless $lines;
  1856.     $self->{_check}{itempos} = ($grammar =~ /\@itempos\b|\$itempos\s*\[/)
  1857.         unless $self->{_check}{itempos};
  1858.     for (qw(thisoffset thiscolumn prevline prevoffset prevcolumn))
  1859.     {
  1860.         $self->{_check}{$_} =
  1861.             ($grammar =~ /\$$_/) || $self->{_check}{itempos}
  1862.                 unless $self->{_check}{$_};
  1863.     }
  1864.     my $line;
  1865.  
  1866.     my $rule = undef;
  1867.     my $prod = undef;
  1868.     my $item = undef;
  1869.     my $lastgreedy = '';
  1870.     pos $grammar = 0;
  1871.     study $grammar;
  1872.  
  1873.     while (pos $grammar < length $grammar)
  1874.     {
  1875.         $line = $lines - _linecount($grammar) + 1;
  1876.         my $commitonly;
  1877.         my $code = "";
  1878.         my @components = ();
  1879.         if ($grammar =~ m/$COMMENT/gco)
  1880.         {
  1881.             _parse("a comment",0,$line);
  1882.             next;
  1883.         }
  1884.         elsif ($grammar =~ m/$NEGLOOKAHEAD/gco)
  1885.         {
  1886.             _parse("a negative lookahead",$aftererror,$line);
  1887.             $lookahead = $lookahead ? -$lookahead : -1;
  1888.             $lookaheadspec .= $1;
  1889.             next;    # SKIP LOOKAHEAD RESET AT END OF while LOOP
  1890.         }
  1891.         elsif ($grammar =~ m/$POSLOOKAHEAD/gco)
  1892.         {
  1893.             _parse("a positive lookahead",$aftererror,$line);
  1894.             $lookahead = $lookahead ? $lookahead : 1;
  1895.             $lookaheadspec .= $1;
  1896.             next;    # SKIP LOOKAHEAD RESET AT END OF while LOOP
  1897.         }
  1898.         elsif ($grammar =~ m/(?=$ACTION)/gco
  1899.             and do { ($code) = extract_codeblock($grammar); $code })
  1900.         {
  1901.             _parse("an action", $aftererror, $line, $code);
  1902.             $item = new Parse::RecDescent::Action($code,$lookahead,$line);
  1903.             $prod and $prod->additem($item)
  1904.                   or  $self->_addstartcode($code);
  1905.         }
  1906.         elsif ($grammar =~ m/(?=$IMPLICITSUBRULE)/gco
  1907.             and do { ($code) = extract_codeblock($grammar,'{([',undef,'(',1);
  1908.                 $code })
  1909.         {
  1910.             $code =~ s/\A\s*\(|\)\Z//g;
  1911.             _parse("an implicit subrule", $aftererror, $line,
  1912.                 "( $code )");
  1913.             my $implicit = $rule->nextimplicit;
  1914.             $self->_generate("$implicit : $code",$replace,1);
  1915.             my $pos = pos $grammar;
  1916.             substr($grammar,$pos,0,$implicit);
  1917.             pos $grammar = $pos;;
  1918.         }
  1919.         elsif ($grammar =~ m/$ENDDIRECTIVEMK/gco)
  1920.         {
  1921.  
  1922.         # EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)
  1923.  
  1924.             my ($minrep,$maxrep) = (1,$MAXREP);
  1925.             if ($grammar =~ m/\G[(]/gc)
  1926.             {
  1927.                 pos($grammar)--;
  1928.  
  1929.                 if ($grammar =~ m/$OPTIONAL/gco)
  1930.                     { ($minrep, $maxrep) = (0,1) }
  1931.                 elsif ($grammar =~ m/$ANY/gco)
  1932.                     { $minrep = 0 }
  1933.                 elsif ($grammar =~ m/$EXACTLY/gco)
  1934.                     { ($minrep, $maxrep) = ($1,$1) }
  1935.                 elsif ($grammar =~ m/$BETWEEN/gco)
  1936.                     { ($minrep, $maxrep) = ($1,$2) }
  1937.                 elsif ($grammar =~ m/$ATLEAST/gco)
  1938.                     { $minrep = $1 }
  1939.                 elsif ($grammar =~ m/$ATMOST/gco)
  1940.                     { $maxrep = $1 }
  1941.                 elsif ($grammar =~ m/$MANY/gco)
  1942.                     { }
  1943.                 elsif ($grammar =~ m/$BADREP/gco)
  1944.                 {
  1945.                     _parse("an invalid repetition specifier", 0,$line);
  1946.                     _error("Incorrect specification of a repeated directive",
  1947.                            $line);
  1948.                     _hint("Repeated directives cannot have
  1949.                            a maximum repetition of zero, nor can they have
  1950.                            negative components in their ranges.");
  1951.                 }
  1952.             }
  1953.             
  1954.             $prod && $prod->enddirective($line,$minrep,$maxrep);
  1955.         }
  1956.         elsif ($grammar =~ m/\G\s*<[^m]/gc)
  1957.         {
  1958.             pos($grammar)-=2;
  1959.  
  1960.             if ($grammar =~ m/$OPMK/gco)
  1961.             {
  1962.                 # $DB::single=1;
  1963.                 _parse("a $1-associative operator directive", $aftererror, $line, "<$1op:...>");
  1964.                 $prod->adddirective($1, $line,$2||'');
  1965.             }
  1966.             elsif ($grammar =~ m/$UNCOMMITMK/gco)
  1967.             {
  1968.                 _parse("an uncommit marker", $aftererror,$line);
  1969.                 $item = new Parse::RecDescent::Directive('$commit=0;1',
  1970.                                   $lookahead,$line,"<uncommit>");
  1971.                 $prod and $prod->additem($item)
  1972.                       or  _no_rule("<uncommit>",$line);
  1973.             }
  1974.             elsif ($grammar =~ m/$QUOTELIKEMK/gco)
  1975.             {
  1976.                 _parse("an perl quotelike marker", $aftererror,$line);
  1977.                 $item = new Parse::RecDescent::Directive(
  1978.                     'my ($match,@res);
  1979.                      ($match,$text,undef,@res) =
  1980.                           Text::Balanced::extract_quotelike($text,$skip);
  1981.                       $match ? \@res : undef;
  1982.                     ', $lookahead,$line,"<perl_quotelike>");
  1983.                 $prod and $prod->additem($item)
  1984.                       or  _no_rule("<perl_quotelike>",$line);
  1985.             }
  1986.             elsif ($grammar =~ m/$CODEBLOCKMK/gco)
  1987.             {
  1988.                 my $outer = $1||"{}";
  1989.                 _parse("an perl codeblock marker", $aftererror,$line);
  1990.                 $item = new Parse::RecDescent::Directive(
  1991.                     'Text::Balanced::extract_codeblock($text,undef,$skip,\''.$outer.'\');
  1992.                     ', $lookahead,$line,"<perl_codeblock>");
  1993.                 $prod and $prod->additem($item)
  1994.                       or  _no_rule("<perl_codeblock>",$line);
  1995.             }
  1996.             elsif ($grammar =~ m/$VARIABLEMK/gco)
  1997.             {
  1998.                 _parse("an perl variable marker", $aftererror,$line);
  1999.                 $item = new Parse::RecDescent::Directive(
  2000.                     'Text::Balanced::extract_variable($text,$skip);
  2001.                     ', $lookahead,$line,"<perl_variable>");
  2002.                 $prod and $prod->additem($item)
  2003.                       or  _no_rule("<perl_variable>",$line);
  2004.             }
  2005.             elsif ($grammar =~ m/$NOCHECKMK/gco)
  2006.             {
  2007.                 _parse("a disable checking marker", $aftererror,$line);
  2008.                 if ($rule)
  2009.                 {
  2010.                     _error("<nocheck> directive not at start of grammar", $line);
  2011.                     _hint("The <nocheck> directive can only
  2012.                            be specified at the start of a
  2013.                            grammar (before the first rule 
  2014.                            is defined.");
  2015.                 }
  2016.                 else
  2017.                 {
  2018.                     local $::RD_CHECK = 1;
  2019.                 }
  2020.             }
  2021.             elsif ($grammar =~ m/$AUTOSTUBMK/gco)
  2022.             {
  2023.                 _parse("an autostub marker", $aftererror,$line);
  2024.                 $::RD_AUTOSTUB = "";
  2025.             }
  2026.             elsif ($grammar =~ m/$AUTORULEMK/gco)
  2027.             {
  2028.                 _parse("an autorule marker", $aftererror,$line);
  2029.                 $::RD_AUTOSTUB = $1;
  2030.             }
  2031.             elsif ($grammar =~ m/$AUTOTREEMK/gco)
  2032.             {
  2033.                 _parse("an autotree marker", $aftererror,$line);
  2034.                 if ($rule)
  2035.                 {
  2036.                     _error("<autotree> directive not at start of grammar", $line);
  2037.                     _hint("The <autotree> directive can only
  2038.                            be specified at the start of a
  2039.                            grammar (before the first rule 
  2040.                            is defined.");
  2041.                 }
  2042.                 else
  2043.                 {
  2044.                     undef $self->{_AUTOACTION};
  2045.                     $self->{_AUTOTREE}{NODE}
  2046.                         = new Parse::RecDescent::Action(q{{bless \%item, $item[0]}},0,-1);
  2047.                     $self->{_AUTOTREE}{TERMINAL}
  2048.                         = new Parse::RecDescent::Action(q{{bless {__VALUE__=>$item[1]}, $item[0]}},0,-1);
  2049.                 }
  2050.             }
  2051.  
  2052.             elsif ($grammar =~ m/$REJECTMK/gco)
  2053.             {
  2054.                 _parse("an reject marker", $aftererror,$line);
  2055.                 $item = new Parse::RecDescent::UncondReject($lookahead,$line,"<reject>");
  2056.                 $prod and $prod->additem($item)
  2057.                       or  _no_rule("<reject>",$line);
  2058.             }
  2059.             elsif ($grammar =~ m/(?=$CONDREJECTMK)/gco
  2060.                 and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
  2061.                       $code })
  2062.             {
  2063.                 _parse("a (conditional) reject marker", $aftererror,$line);
  2064.                 $code =~ /\A\s*<reject:(.*)>\Z/s;
  2065.                 $item = new Parse::RecDescent::Directive(
  2066.                           "($1) ? undef : 1", $lookahead,$line,"<reject:$code>");
  2067.                 $prod and $prod->additem($item)
  2068.                       or  _no_rule("<reject:$code>",$line);
  2069.             }
  2070.             elsif ($grammar =~ m/(?=$SCOREMK)/gco
  2071.                 and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
  2072.                       $code })
  2073.             {
  2074.                 _parse("a score marker", $aftererror,$line);
  2075.                 $code =~ /\A\s*<score:(.*)>\Z/s;
  2076.                 $prod and $prod->addscore($1, $lookahead, $line)
  2077.                       or  _no_rule($code,$line);
  2078.             }
  2079.             elsif ($grammar =~ m/(?=$AUTOSCOREMK)/gco
  2080.                 and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
  2081.                      $code;
  2082.                        } )
  2083.             {
  2084.                 _parse("an autoscore specifier", $aftererror,$line,$code);
  2085.                 $code =~ /\A\s*<autoscore:(.*)>\Z/s;
  2086.  
  2087.                 $rule and $rule->addautoscore($1,$self)
  2088.                       or  _no_rule($code,$line);
  2089.  
  2090.                 $item = new Parse::RecDescent::UncondReject($lookahead,$line,$code);
  2091.                 $prod and $prod->additem($item)
  2092.                       or  _no_rule($code,$line);
  2093.             }
  2094.             elsif ($grammar =~ m/$RESYNCMK/gco)
  2095.             {
  2096.                 _parse("a resync to newline marker", $aftererror,$line);
  2097.                 $item = new Parse::RecDescent::Directive(
  2098.                           'if ($text =~ s/\A[^\n]*\n//) { $return = 0; $& } else { undef }',
  2099.                           $lookahead,$line,"<resync>");
  2100.                 $prod and $prod->additem($item)
  2101.                       or  _no_rule("<resync>",$line);
  2102.             }
  2103.             elsif ($grammar =~ m/(?=$RESYNCPATMK)/gco
  2104.                 and do { ($code) = extract_bracketed($grammar,'<');
  2105.                       $code })
  2106.             {
  2107.                 _parse("a resync with pattern marker", $aftererror,$line);
  2108.                 $code =~ /\A\s*<resync:(.*)>\Z/s;
  2109.                 $item = new Parse::RecDescent::Directive(
  2110.                           'if ($text =~ s/\A'.$1.'//) { $return = 0; $& } else { undef }',
  2111.                           $lookahead,$line,$code);
  2112.                 $prod and $prod->additem($item)
  2113.                       or  _no_rule($code,$line);
  2114.             }
  2115.             elsif ($grammar =~ m/(?=$SKIPMK)/gco
  2116.                 and do { ($code) = extract_codeblock($grammar,'<');
  2117.                       $code })
  2118.             {
  2119.                 _parse("a skip marker", $aftererror,$line);
  2120.                 $code =~ /\A\s*<skip:(.*)>\Z/s;
  2121.                 $item = new Parse::RecDescent::Directive(
  2122.                           'my $oldskip = $skip; $skip='.$1.'; $oldskip',
  2123.                           $lookahead,$line,$code);
  2124.                 $prod and $prod->additem($item)
  2125.                       or  _no_rule($code,$line);
  2126.             }
  2127.             elsif ($grammar =~ m/(?=$RULEVARPATMK)/gco
  2128.                 and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
  2129.                      $code;
  2130.                        } )
  2131.             {
  2132.                 _parse("a rule variable specifier", $aftererror,$line,$code);
  2133.                 $code =~ /\A\s*<rulevar:(.*)>\Z/s;
  2134.  
  2135.                 $rule and $rule->addvar($1,$self)
  2136.                       or  _no_rule($code,$line);
  2137.  
  2138.                 $item = new Parse::RecDescent::UncondReject($lookahead,$line,$code);
  2139.                 $prod and $prod->additem($item)
  2140.                       or  _no_rule($code,$line);
  2141.             }
  2142.             elsif ($grammar =~ m/(?=$DEFERPATMK)/gco
  2143.                 and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
  2144.                      $code;
  2145.                        } )
  2146.             {
  2147.                 _parse("a deferred action specifier", $aftererror,$line,$code);
  2148.                 $code =~ s/\A\s*<defer:(.*)>\Z/$1/s;
  2149.                 if ($code =~ /\A\s*[^{]|[^}]\s*\Z/)
  2150.                 {
  2151.                     $code = "{ $code }"
  2152.                 }
  2153.  
  2154.                 $item = new Parse::RecDescent::Directive(
  2155.                           "push \@{\$thisparser->{deferred}}, sub $code;",
  2156.                           $lookahead,$line,"<defer:$code>");
  2157.                 $prod and $prod->additem($item)
  2158.                       or  _no_rule("<defer:$code>",$line);
  2159.  
  2160.                 $self->{deferrable} = 1;
  2161.             }
  2162.             elsif ($grammar =~ m/(?=$TOKENPATMK)/gco
  2163.                 and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
  2164.                      $code;
  2165.                        } )
  2166.             {
  2167.                 _parse("a token constructor", $aftererror,$line,$code);
  2168.                 $code =~ s/\A\s*<token:(.*)>\Z/$1/s;
  2169.  
  2170.                 my $types = eval 'no strict; local $SIG{__WARN__} = sub {0}; my @arr=('.$code.'); @arr' || (); 
  2171.                 if (!$types)
  2172.                 {
  2173.                     _error("Incorrect token specification: \"$@\"", $line);
  2174.                     _hint("The <token:...> directive requires a list
  2175.                            of one or more strings representing possible
  2176.                            types of the specified token. For example:
  2177.                            <token:NOUN,VERB>");
  2178.                 }
  2179.                 else
  2180.                 {
  2181.                     $item = new Parse::RecDescent::Directive(
  2182.                               'no strict;
  2183.                                $return = { text => $item[-1] };
  2184.                                @{$return->{type}}{'.$code.'} = (1..'.$types.');',
  2185.                               $lookahead,$line,"<token:$code>");
  2186.                     $prod and $prod->additem($item)
  2187.                           or  _no_rule("<token:$code>",$line);
  2188.                 }
  2189.             }
  2190.             elsif ($grammar =~ m/$COMMITMK/gco)
  2191.             {
  2192.                 _parse("an commit marker", $aftererror,$line);
  2193.                 $item = new Parse::RecDescent::Directive('$commit = 1',
  2194.                                   $lookahead,$line,"<commit>");
  2195.                 $prod and $prod->additem($item)
  2196.                       or  _no_rule("<commit>",$line);
  2197.             }
  2198.             elsif ($grammar =~ m/$AUTOERRORMK/gco)
  2199.             {
  2200.                 $commitonly = $1;
  2201.                 _parse("an error marker", $aftererror,$line);
  2202.                 $item = new Parse::RecDescent::Error('',$lookahead,$1,$line);
  2203.                 $prod and $prod->additem($item)
  2204.                       or  _no_rule("<error>",$line);
  2205.                 $aftererror = !$commitonly;
  2206.             }
  2207.             elsif ($grammar =~ m/(?=$MSGERRORMK)/gco
  2208.                 and do { $commitonly = $1;
  2209.                      ($code) = extract_bracketed($grammar,'<');
  2210.                     $code })
  2211.             {
  2212.                 _parse("an error marker", $aftererror,$line,$code);
  2213.                 $code =~ /\A\s*<error\??:(.*)>\Z/s;
  2214.                 $item = new Parse::RecDescent::Error($1,$lookahead,$commitonly,$line);
  2215.                 $prod and $prod->additem($item)
  2216.                       or  _no_rule("$code",$line);
  2217.                 $aftererror = !$commitonly;
  2218.             }
  2219.             elsif (do { $commitonly = $1;
  2220.                      ($code) = extract_bracketed($grammar,'<');
  2221.                     $code })
  2222.             {
  2223.                 if ($code =~ /^<[A-Z_]+>$/)
  2224.                 {
  2225.                     _error("Token items are not yet
  2226.                     supported: \"$code\"",
  2227.                            $line);
  2228.                     _hint("Items like $code that consist of angle
  2229.                     brackets enclosing a sequence of
  2230.                     uppercase characters will eventually
  2231.                     be used to specify pre-lexed tokens
  2232.                     in a grammar. That functionality is not
  2233.                     yet implemented. Or did you misspell
  2234.                     \"$code\"?");
  2235.                 }
  2236.                 else
  2237.                 {
  2238.                     _error("Untranslatable item encountered: \"$code\"",
  2239.                            $line);
  2240.                     _hint("Did you misspell \"$code\"
  2241.                            or forget to comment it out?");
  2242.                 }
  2243.             }
  2244.         }
  2245.         elsif ($grammar =~ m/$RULE/gco)
  2246.         {
  2247.             _parseunneg("a rule declaration", 0,
  2248.                     $lookahead,$line) or next;
  2249.             my $rulename = $1;
  2250.             if ($rulename =~ /Replace|Extend|Precompile|Save/ )
  2251.             {    
  2252.                 _warn(2,"Rule \"$rulename\" hidden by method
  2253.                        Parse::RecDescent::$rulename",$line)
  2254.                 and
  2255.                 _hint("The rule named \"$rulename\" cannot be directly
  2256.                                        called through the Parse::RecDescent object
  2257.                                        for this grammar (although it may still
  2258.                                        be used as a subrule of other rules).
  2259.                                        It can't be directly called because
  2260.                        Parse::RecDescent::$rulename is already defined (it
  2261.                        is the standard method of all
  2262.                        parsers).");
  2263.             }
  2264.             $rule = new Parse::RecDescent::Rule($rulename,$self,$line,$replace);
  2265.             $prod->check_pending($line) if $prod;
  2266.             $prod = $rule->addprod( new Parse::RecDescent::Production );
  2267.             $aftererror = 0;
  2268.         }
  2269.         elsif ($grammar =~ m/$UNCOMMITPROD/gco)
  2270.         {
  2271.             pos($grammar)-=9;
  2272.             _parseunneg("a new (uncommitted) production",
  2273.                     0, $lookahead, $line) or next;
  2274.  
  2275.             $prod->check_pending($line) if $prod;
  2276.             $prod = new Parse::RecDescent::Production($line,1);
  2277.             $rule and $rule->addprod($prod)
  2278.                   or  _no_rule("<uncommit>",$line);
  2279.             $aftererror = 0;
  2280.         }
  2281.         elsif ($grammar =~ m/$ERRORPROD/gco)
  2282.         {
  2283.             pos($grammar)-=6;
  2284.             _parseunneg("a new (error) production", $aftererror,
  2285.                     $lookahead,$line) or next;
  2286.             $prod->check_pending($line) if $prod;
  2287.             $prod = new Parse::RecDescent::Production($line,0,1);
  2288.             $rule and $rule->addprod($prod)
  2289.                   or  _no_rule("<error>",$line);
  2290.             $aftererror = 0;
  2291.         }
  2292.         elsif ($grammar =~ m/$PROD/gco)
  2293.         {
  2294.             _parseunneg("a new production", 0,
  2295.                     $lookahead,$line) or next;
  2296.             $rule
  2297.               and (!$prod || $prod->check_pending($line))
  2298.               and $prod = $rule->addprod(new Parse::RecDescent::Production($line))
  2299.             or  _no_rule("production",$line);
  2300.             $aftererror = 0;
  2301.         }
  2302.         elsif ($grammar =~ m/$LITERAL/gco)
  2303.         {
  2304.             ($code = $1) =~ s/\\\\/\\/g;
  2305.             _parse("a literal terminal", $aftererror,$line,$1);
  2306.             $item = new Parse::RecDescent::Literal($code,$lookahead,$line);
  2307.             $prod and $prod->additem($item)
  2308.                   or  _no_rule("literal terminal",$line,"'$1'");
  2309.         }
  2310.         elsif ($grammar =~ m/$INTERPLIT/gco)
  2311.         {
  2312.             _parse("an interpolated literal terminal", $aftererror,$line);
  2313.             $item = new Parse::RecDescent::InterpLit($1,$lookahead,$line);
  2314.             $prod and $prod->additem($item)
  2315.                   or  _no_rule("interpolated literal terminal",$line,"'$1'");
  2316.         }
  2317.         elsif ($grammar =~ m/$TOKEN/gco)
  2318.         {
  2319.             _parse("a /../ pattern terminal", $aftererror,$line);
  2320.             $item = new Parse::RecDescent::Token($1,'/',$3?$3:'',$lookahead,$line);
  2321.             $prod and $prod->additem($item)
  2322.                   or  _no_rule("pattern terminal",$line,"/$1/");
  2323.         }
  2324.         elsif ($grammar =~ m/(?=$MTOKEN)/gco
  2325.             and do { ($code, undef, @components)
  2326.                     = extract_quotelike($grammar);
  2327.                  $code }
  2328.               )
  2329.  
  2330.         {
  2331.             _parse("an m/../ pattern terminal", $aftererror,$line,$code);
  2332.             $item = new Parse::RecDescent::Token(@components[3,2,8],
  2333.                                  $lookahead,$line);
  2334.             $prod and $prod->additem($item)
  2335.                   or  _no_rule("pattern terminal",$line,$code);
  2336.         }
  2337.         elsif ($grammar =~ m/(?=$MATCHRULE)/gco
  2338.                 and do { ($code) = extract_bracketed($grammar,'<');
  2339.                      $code
  2340.                        }
  2341.                or $grammar =~ m/$SUBRULE/gco
  2342.                 and $code = $1)
  2343.         {
  2344.             my $name = $code;
  2345.             my $matchrule = 0;
  2346.             if (substr($name,0,1) eq '<')
  2347.             {
  2348.                 $name =~ s/$MATCHRULE\s*//;
  2349.                 $name =~ s/\s*>\Z//;
  2350.                 $matchrule = 1;
  2351.             }
  2352.  
  2353.         # EXTRACT TRAILING ARG LIST (IF ANY)
  2354.  
  2355.             my ($argcode) = extract_codeblock($grammar, "[]",'') || '';
  2356.  
  2357.         # EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)
  2358.  
  2359.             if ($grammar =~ m/\G[(]/gc)
  2360.             {
  2361.                 pos($grammar)--;
  2362.  
  2363.                 if ($grammar =~ m/$OPTIONAL/gco)
  2364.                 {
  2365.                     _parse("an zero-or-one subrule match", $aftererror,$line,"$code$argcode($1)");
  2366.                     $item = new Parse::RecDescent::Repetition($name,$1,0,1,
  2367.                                        $lookahead,$line,
  2368.                                        $self,
  2369.                                        $matchrule,
  2370.                                        $argcode);
  2371.                     $prod and $prod->additem($item)
  2372.                           or  _no_rule("repetition",$line,"$code$argcode($1)");
  2373.  
  2374.                     !$matchrule and $rule and $rule->addcall($name);
  2375.                 }
  2376.                 elsif ($grammar =~ m/$ANY/gco)
  2377.                 {
  2378.                     _parse("a zero-or-more subrule match", $aftererror,$line,"$code$argcode($1)");
  2379.                     if ($2)
  2380.                     {
  2381.                         my $pos = pos $grammar;
  2382.                         substr($grammar,$pos,0,
  2383.                                "<leftop='$name(s?)': $name $2 $name>(s?) ");
  2384.  
  2385.                         pos $grammar = $pos;
  2386.                     }
  2387.                     else
  2388.                     {
  2389.                         $item = new Parse::RecDescent::Repetition($name,$1,0,$MAXREP,
  2390.                                            $lookahead,$line,
  2391.                                            $self,
  2392.                                            $matchrule,
  2393.                                            $argcode);
  2394.                         $prod and $prod->additem($item)
  2395.                               or  _no_rule("repetition",$line,"$code$argcode($1)");
  2396.  
  2397.                         !$matchrule and $rule and $rule->addcall($name);
  2398.  
  2399.                         _check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK;
  2400.                     }
  2401.                 }
  2402.                 elsif ($grammar =~ m/$MANY/gco)
  2403.                 {
  2404.                     _parse("a one-or-more subrule match", $aftererror,$line,"$code$argcode($1)");
  2405.                     if ($2)
  2406.                     {
  2407.                         # $DB::single=1;
  2408.                         my $pos = pos $grammar;
  2409.                         substr($grammar,$pos,0,
  2410.                                "<leftop='$name(s)': $name $2 $name> ");
  2411.  
  2412.                         pos $grammar = $pos;
  2413.                     }
  2414.                     else
  2415.                     {
  2416.                         $item = new Parse::RecDescent::Repetition($name,$1,1,$MAXREP,
  2417.                                            $lookahead,$line,
  2418.                                            $self,
  2419.                                            $matchrule,
  2420.                                            $argcode);
  2421.                                            
  2422.                         $prod and $prod->additem($item)
  2423.                               or  _no_rule("repetition",$line,"$code$argcode($1)");
  2424.  
  2425.                         !$matchrule and $rule and $rule->addcall($name);
  2426.  
  2427.                         _check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK;
  2428.                     }
  2429.                 }
  2430.                 elsif ($grammar =~ m/$EXACTLY/gco)
  2431.                 {
  2432.                     _parse("an exactly-$1-times subrule match", $aftererror,$line,"$code$argcode($1)");
  2433.                     if ($2)
  2434.                     {
  2435.                         my $pos = pos $grammar;
  2436.                         substr($grammar,$pos,0,
  2437.                                "<leftop='$name($1)': $name $2 $name>($1) ");
  2438.  
  2439.                         pos $grammar = $pos;
  2440.                     }
  2441.                     else
  2442.                     {
  2443.                         $item = new Parse::RecDescent::Repetition($name,$1,$1,$1,
  2444.                                            $lookahead,$line,
  2445.                                            $self,
  2446.                                            $matchrule,
  2447.                                            $argcode);
  2448.                         $prod and $prod->additem($item)
  2449.                               or  _no_rule("repetition",$line,"$code$argcode($1)");
  2450.  
  2451.                         !$matchrule and $rule and $rule->addcall($name);
  2452.                     }
  2453.                 }
  2454.                 elsif ($grammar =~ m/$BETWEEN/gco)
  2455.                 {
  2456.                     _parse("a $1-to-$2 subrule match", $aftererror,$line,"$code$argcode($1..$2)");
  2457.                     if ($3)
  2458.                     {
  2459.                         my $pos = pos $grammar;
  2460.                         substr($grammar,$pos,0,
  2461.                                "<leftop='$name($1..$2)': $name $3 $name>($1..$2) ");
  2462.  
  2463.                         pos $grammar = $pos;
  2464.                     }
  2465.                     else
  2466.                     {
  2467.                         $item = new Parse::RecDescent::Repetition($name,"$1..$2",$1,$2,
  2468.                                            $lookahead,$line,
  2469.                                            $self,
  2470.                                            $matchrule,
  2471.                                            $argcode);
  2472.                         $prod and $prod->additem($item)
  2473.                               or  _no_rule("repetition",$line,"$code$argcode($1..$2)");
  2474.  
  2475.                         !$matchrule and $rule and $rule->addcall($name);
  2476.                     }
  2477.                 }
  2478.                 elsif ($grammar =~ m/$ATLEAST/gco)
  2479.                 {
  2480.                     _parse("a $1-or-more subrule match", $aftererror,$line,"$code$argcode($1..)");
  2481.                     if ($2)
  2482.                     {
  2483.                         my $pos = pos $grammar;
  2484.                         substr($grammar,$pos,0,
  2485.                                "<leftop='$name($1..)': $name $2 $name>($1..) ");
  2486.  
  2487.                         pos $grammar = $pos;
  2488.                     }
  2489.                     else
  2490.                     {
  2491.                         $item = new Parse::RecDescent::Repetition($name,"$1..",$1,$MAXREP,
  2492.                                            $lookahead,$line,
  2493.                                            $self,
  2494.                                            $matchrule,
  2495.                                            $argcode);
  2496.                         $prod and $prod->additem($item)
  2497.                               or  _no_rule("repetition",$line,"$code$argcode($1..)");
  2498.  
  2499.                         !$matchrule and $rule and $rule->addcall($name);
  2500.                         _check_insatiable($name,"$1..",$grammar,$line) if $::RD_CHECK;
  2501.                     }
  2502.                 }
  2503.                 elsif ($grammar =~ m/$ATMOST/gco)
  2504.                 {
  2505.                     _parse("a one-to-$1 subrule match", $aftererror,$line,"$code$argcode(..$1)");
  2506.                     if ($2)
  2507.                     {
  2508.                         my $pos = pos $grammar;
  2509.                         substr($grammar,$pos,0,
  2510.                                "<leftop='$name(..$1)': $name $2 $name>(..$1) ");
  2511.  
  2512.                         pos $grammar = $pos;
  2513.                     }
  2514.                     else
  2515.                     {
  2516.                         $item = new Parse::RecDescent::Repetition($name,"..$1",1,$1,
  2517.                                            $lookahead,$line,
  2518.                                            $self,
  2519.                                            $matchrule,
  2520.                                            $argcode);
  2521.                         $prod and $prod->additem($item)
  2522.                               or  _no_rule("repetition",$line,"$code$argcode(..$1)");
  2523.  
  2524.                         !$matchrule and $rule and $rule->addcall($name);
  2525.                     }
  2526.                 }
  2527.                 elsif ($grammar =~ m/$BADREP/gco)
  2528.                 {
  2529.                     _parse("an subrule match with invalid repetition specifier", 0,$line);
  2530.                     _error("Incorrect specification of a repeated subrule",
  2531.                            $line);
  2532.                     _hint("Repeated subrules like \"$code$argcode$&\" cannot have
  2533.                            a maximum repetition of zero, nor can they have
  2534.                            negative components in their ranges.");
  2535.                 }
  2536.             }
  2537.             else
  2538.             {
  2539.                 _parse("a subrule match", $aftererror,$line,$code);
  2540.                 my $desc;
  2541.                 if ($name=~/\A_alternation_\d+_of_production_\d+_of_rule/)
  2542.                     { $desc = $self->{"rules"}{$name}->expected }
  2543.                 $item = new Parse::RecDescent::Subrule($name,
  2544.                                        $lookahead,
  2545.                                        $line,
  2546.                                        $desc,
  2547.                                        $matchrule,
  2548.                                        $argcode);
  2549.      
  2550.                 $prod and $prod->additem($item)
  2551.                       or  _no_rule("(sub)rule",$line,$name);
  2552.  
  2553.                 !$matchrule and $rule and $rule->addcall($name);
  2554.             }
  2555.         }
  2556.         elsif ($grammar =~ m/$LONECOLON/gco   )
  2557.         {
  2558.             _error("Unexpected colon encountered", $line);
  2559.             _hint("Did you mean \"|\" (to start a new production)?
  2560.                        Or perhaps you forgot that the colon
  2561.                    in a rule definition must be
  2562.                    on the same line as the rule name?");
  2563.         }
  2564.         elsif ($grammar =~ m/$ACTION/gco   ) # BAD ACTION, ALREADY FAILED
  2565.         {
  2566.             _error("Malformed action encountered",
  2567.                    $line);
  2568.             _hint("Did you forget the closing curly bracket
  2569.                    or is there a syntax error in the action?");
  2570.         }
  2571.         elsif ($grammar =~ m/$OTHER/gco   )
  2572.         {
  2573.             _error("Untranslatable item encountered: \"$1\"",
  2574.                    $line);
  2575.             _hint("Did you misspell \"$1\"
  2576.                        or forget to comment it out?");
  2577.         }
  2578.  
  2579.         if ($lookaheadspec =~ tr /././ > 3)
  2580.         {
  2581.             $lookaheadspec =~ s/\A\s+//;
  2582.             $lookahead = $lookahead<0
  2583.                     ? 'a negative lookahead ("...!")'
  2584.                     : 'a positive lookahead ("...")' ;
  2585.             _warn(1,"Found two or more lookahead specifiers in a
  2586.                    row.",$line)
  2587.             and
  2588.             _hint("Multiple positive and/or negative lookaheads
  2589.                    are simply multiplied together to produce a
  2590.                    single positive or negative lookahead
  2591.                    specification. In this case the sequence
  2592.                    \"$lookaheadspec\" was reduced to $lookahead.
  2593.                    Was this your intention?");
  2594.         }
  2595.         $lookahead = 0;
  2596.         $lookaheadspec = "";
  2597.  
  2598.         $grammar =~ m/\G\s+/gc;
  2599.     }
  2600.  
  2601.     unless ($ERRORS or $isimplicit or !$::RD_CHECK)
  2602.     {
  2603.         $self->_check_grammar();
  2604.     }
  2605.  
  2606.     unless ($ERRORS or $isimplicit or $Parse::RecDescent::compiling)
  2607.     {
  2608.         my $code = $self->_code();
  2609.         if (defined $::RD_TRACE)
  2610.         {
  2611.             print STDERR "printing code (", length($code),") to RD_TRACE\n";
  2612.             local *TRACE_FILE;
  2613.             open TRACE_FILE, ">RD_TRACE"
  2614.             and print TRACE_FILE "my \$ERRORS;\n$code"
  2615.             and close TRACE_FILE;
  2616.         }
  2617.  
  2618.         unless ( eval "$code 1" )
  2619.         {
  2620.             _error("Internal error in generated parser code!");
  2621.             $@ =~ s/at grammar/in grammar at/;
  2622.             _hint($@);
  2623.         }
  2624.     }
  2625.  
  2626.     if ($ERRORS and !_verbosity("HINT"))
  2627.     {
  2628.         local $::RD_HINT = 1;
  2629.         _hint('Set $::RD_HINT (or -RD_HINT if you\'re using "perl -s")
  2630.                for hints on fixing these problems.');
  2631.     }
  2632.     if ($ERRORS) { $ERRORS=0; return }
  2633.     return $self;
  2634. }
  2635.  
  2636.  
  2637. sub _addstartcode($$)
  2638. {
  2639.     my ($self, $code) = @_;
  2640.     $code =~ s/\A\s*\{(.*)\}\Z/$1/s;
  2641.  
  2642.     $self->{"startcode"} .= "$code;\n";
  2643. }
  2644.  
  2645. # CHECK FOR GRAMMAR PROBLEMS....
  2646.  
  2647. sub _check_insatiable($$$$)
  2648. {
  2649.     my ($subrule,$repspec,$grammar,$line) = @_;
  2650.     pos($grammar)=pos($_[2]);
  2651.     return if $grammar =~ m/$OPTIONAL/gco || $grammar =~ m/$ANY/gco;
  2652.     my $min = 1;
  2653.     if ( $grammar =~ m/$MANY/gco
  2654.       || $grammar =~ m/$EXACTLY/gco
  2655.       || $grammar =~ m/$ATMOST/gco
  2656.       || $grammar =~ m/$BETWEEN/gco && do { $min=$2; 1 }
  2657.       || $grammar =~ m/$ATLEAST/gco && do { $min=$2; 1 }
  2658.       || $grammar =~ m/$SUBRULE(?!\s*:)/gco
  2659.        )
  2660.     {
  2661.         return unless $1 eq $subrule && $min > 0;
  2662.         _warn(3,"Subrule sequence \"$subrule($repspec) $&\" will
  2663.                (almost certainly) fail.",$line)
  2664.         and
  2665.         _hint("Unless subrule \"$subrule\" performs some cunning
  2666.                lookahead, the repetition \"$subrule($repspec)\" will
  2667.                insatiably consume as many matches of \"$subrule\" as it
  2668.                can, leaving none to match the \"$&\" that follows.");
  2669.     }
  2670. }
  2671.  
  2672. sub _check_grammar ($)
  2673. {
  2674.     my $self = shift;
  2675.     my $rules = $self->{"rules"};
  2676.     my $rule;
  2677.     foreach $rule ( values %$rules )
  2678.     {
  2679.         next if ! $rule->{"changed"};
  2680.  
  2681.     # CHECK FOR UNDEFINED RULES
  2682.  
  2683.         my $call;
  2684.         foreach $call ( @{$rule->{"calls"}} )
  2685.         {
  2686.             if (!defined ${$rules}{$call}
  2687.               &&!defined &{"Parse::RecDescent::$call"})
  2688.             {
  2689.                 if (!defined $::RD_AUTOSTUB)
  2690.                 {
  2691.                     _warn(3,"Undefined (sub)rule \"$call\"
  2692.                           used in a production.")
  2693.                     and
  2694.                     _hint("Will you be providing this rule
  2695.                            later, or did you perhaps
  2696.                            misspell \"$call\"? Otherwise
  2697.                            it will be treated as an 
  2698.                            immediate <reject>.");
  2699.                     eval "sub $self->{namespace}::$call {undef}";
  2700.                 }
  2701.                 else    # EXPERIMENTAL
  2702.                 {
  2703.                     my $rule = $::RD_AUTOSTUB || qq{'$call'};
  2704.                     _warn(1,"Autogenerating rule: $call")
  2705.                     and
  2706.                     _hint("A call was made to a subrule
  2707.                            named \"$call\", but no such
  2708.                            rule was specified. However,
  2709.                            since \$::RD_AUTOSTUB
  2710.                            was defined, a rule stub
  2711.                            ($call : $rule) was
  2712.                            automatically created.");
  2713.  
  2714.                     $self->_generate("$call : $rule",0,1);
  2715.                 }
  2716.             }
  2717.         }
  2718.  
  2719.     # CHECK FOR LEFT RECURSION
  2720.  
  2721.         if ($rule->isleftrec($rules))
  2722.         {
  2723.             _error("Rule \"$rule->{name}\" is left-recursive.");
  2724.             _hint("Redesign the grammar so it's not left-recursive.
  2725.                    That will probably mean you need to re-implement
  2726.                    repetitions using the '(s)' notation.
  2727.                    For example: \"$rule->{name}(s)\".");
  2728.             next;
  2729.         }
  2730.     }
  2731. }
  2732.     
  2733. # GENERATE ACTUAL PARSER CODE
  2734.  
  2735. sub _code($)
  2736. {
  2737.     my $self = shift;
  2738.     my $code = qq{
  2739. package $self->{namespace};
  2740. use strict;
  2741. use vars qw(\$skip \$AUTOLOAD $self->{localvars} );
  2742. \$skip = '$skip';
  2743. $self->{startcode}
  2744.  
  2745. {
  2746. local \$SIG{__WARN__} = sub {0};
  2747. # PRETEND TO BE IN Parse::RecDescent NAMESPACE
  2748. *$self->{namespace}::AUTOLOAD    = sub
  2749. {
  2750.     no strict 'refs';
  2751.     \$AUTOLOAD =~ s/^$self->{namespace}/Parse::RecDescent/;
  2752.     goto &{\$AUTOLOAD};
  2753. }
  2754. }
  2755.  
  2756. };
  2757.     $code .= "push \@$self->{namespace}\::ISA, 'Parse::RecDescent';";
  2758.     $self->{"startcode"} = '';
  2759.  
  2760.     my $rule;
  2761.     foreach $rule ( values %{$self->{"rules"}} )
  2762.     {
  2763.         if ($rule->{"changed"})
  2764.         {
  2765.             $code .= $rule->code($self->{"namespace"},$self);
  2766.             $rule->{"changed"} = 0;
  2767.         }
  2768.     }
  2769.  
  2770.     return $code;
  2771. }
  2772.  
  2773.  
  2774. # EXECUTING A PARSE....
  2775.  
  2776. sub AUTOLOAD    # ($parser, $text; $linenum, @args)
  2777. {
  2778.     croak "Could not find method: $AUTOLOAD\n" unless ref $_[0];
  2779.     my $class = ref($_[0]) || $_[0];
  2780.     my $text = ref($_[1]) ? ${$_[1]} : $_[1];
  2781.     $_[0]->{lastlinenum} = $_[2]||_linecount($_[1]);
  2782.     $_[0]->{lastlinenum} = _linecount($_[1]);
  2783.     $_[0]->{lastlinenum} += $_[2] if @_ > 2;
  2784.     $_[0]->{offsetlinenum} = $_[0]->{lastlinenum};
  2785.     $_[0]->{fulltext} = $text;
  2786.     $_[0]->{fulltextlen} = length $text;
  2787.     $_[0]->{deferred} = [];
  2788.     $_[0]->{errors} = [];
  2789.     my @args = @_[3..$#_];
  2790.     my $args = sub { [ @args ] };
  2791.                  
  2792.     $AUTOLOAD =~ s/$class/$_[0]->{namespace}/;
  2793.     no strict "refs";
  2794.     
  2795.     croak "Unknown starting rule ($AUTOLOAD) called\n"
  2796.         unless defined &$AUTOLOAD;
  2797.     my $retval = &{$AUTOLOAD}($_[0],$text,undef,undef,$args);
  2798.  
  2799.     if (defined $retval)
  2800.     {
  2801.         foreach ( @{$_[0]->{deferred}} ) { &$_; }
  2802.     }
  2803.     else
  2804.     {
  2805.         foreach ( @{$_[0]->{errors}} ) { _error(@$_); }
  2806.     }
  2807.  
  2808.     if (ref $_[1]) { ${$_[1]} = $text }
  2809.  
  2810.     $ERRORS = 0;
  2811.     return $retval;
  2812. }
  2813.  
  2814. sub _parserepeat($$$$$$$$$$)    # RETURNS A REF TO AN ARRAY OF MATCHES
  2815. {
  2816.     my ($parser, $text, $prod, $min, $max, $_noactions, $expectation, $argcode) = @_;
  2817.     my @tokens = ();
  2818.     
  2819.     my $reps;
  2820.     for ($reps=0; $reps<$max;)
  2821.     {
  2822.         $_[6]->at($text);     # $_[6] IS $expectation FROM CALLER
  2823.         my $_savetext = $text;
  2824.         my $prevtextlen = length $text;
  2825.         my $_tok;
  2826.         if (! defined ($_tok = &$prod($parser,$text,1,$_noactions,$argcode)))
  2827.         {
  2828.             $text = $_savetext;
  2829.             last;
  2830.         }
  2831.         push @tokens, $_tok if defined $_tok;
  2832.         last if ++$reps >= $min and $prevtextlen == length $text;
  2833.     }
  2834.  
  2835.     do { $_[6]->failed(); return undef} if $reps<$min;
  2836.  
  2837.     $_[1] = $text;
  2838.     return [@tokens];
  2839. }
  2840.  
  2841.  
  2842. # ERROR REPORTING....
  2843.  
  2844. my $errortext;
  2845. my $errorprefix;
  2846.  
  2847. open (ERROR, ">&STDERR");
  2848. format ERROR =
  2849. @>>>>>>>>>>>>>>>>>>>>: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  2850. $errorprefix,          $errortext
  2851. ~~                     ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  2852.                        $errortext
  2853. .
  2854.  
  2855. select ERROR;
  2856. $| = 1;
  2857.  
  2858. # TRACING
  2859.  
  2860. my $tracemsg;
  2861. my $tracecontext;
  2862. my $tracerulename;
  2863. use vars '$tracelevel';
  2864.  
  2865. open (TRACE, ">&STDERR");
  2866. format TRACE =
  2867. @>|@|||||||||@^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
  2868. $tracelevel, $tracerulename, '|', $tracemsg
  2869.   | ~~       |^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
  2870.               $tracemsg
  2871. .
  2872.  
  2873. select TRACE;
  2874. $| = 1;
  2875.  
  2876. open (TRACECONTEXT, ">&STDERR");
  2877. format TRACECONTEXT =
  2878. @>|@|||||||||@                                      |^<<<<<<<<<<<<<<<<<<<<<<<<<<<
  2879. $tracelevel, $tracerulename, '|',               $tracecontext
  2880.   | ~~       |                                      |^<<<<<<<<<<<<<<<<<<<<<<<<<<<
  2881.                            $tracecontext
  2882. .
  2883.  
  2884.  
  2885. select TRACECONTEXT;
  2886. $| = 1;
  2887.  
  2888. select STDOUT;
  2889.  
  2890. sub _verbosity($)
  2891. {
  2892.        defined $::RD_TRACE
  2893.     or defined $::RD_HINT    and  $_[0] =~ /ERRORS|WARN|HINT/
  2894.     or defined $::RD_WARN    and  $_[0] =~ /ERRORS|WARN/
  2895.     or defined $::RD_ERRORS  and  $_[0] =~ /ERRORS/
  2896. }
  2897.  
  2898. sub _error($;$)
  2899. {
  2900.     $ERRORS++;
  2901.     return 0 if ! _verbosity("ERRORS");
  2902.     $errortext   = $_[0];
  2903.     $errorprefix = "ERROR" .  ($_[1] ? " (line $_[1])" : "");
  2904.     $errortext =~ s/\s+/ /g;
  2905.     print ERROR "\n" if _verbosity("WARN");
  2906.     write ERROR;
  2907.     return 1;
  2908. }
  2909.  
  2910. sub _warn($$;$)
  2911. {
  2912.     return 0 unless _verbosity("WARN") && ($::RD_HINT || $_[0] >= ($::RD_WARN||1));
  2913.     $errortext   = $_[1];
  2914.     $errorprefix = "Warning" .  ($_[2] ? " (line $_[2])" : "");
  2915.     print ERROR "\n";
  2916.     $errortext =~ s/\s+/ /g;
  2917.     write ERROR;
  2918.     return 1;
  2919. }
  2920.  
  2921. sub _hint($)
  2922. {
  2923.     return 0 unless defined $::RD_HINT;
  2924.     $errortext = "$_[0])";
  2925.     $errorprefix = "(Hint";
  2926.     $errortext =~ s/\s+/ /g;
  2927.     write ERROR;
  2928.     return 1;
  2929. }
  2930.  
  2931. sub _tracemax($)
  2932. {
  2933.     if (defined $::RD_TRACE
  2934.         && $::RD_TRACE =~ /\d+/
  2935.         && $::RD_TRACE>1
  2936.         && $::RD_TRACE+10<length($_[0]))
  2937.     {
  2938.         my $count = length($_[0]) - $::RD_TRACE;
  2939.         return substr($_[0],0,$::RD_TRACE/2)
  2940.             . "...<$count>..."
  2941.             . substr($_[0],-$::RD_TRACE/2);
  2942.     }
  2943.     else
  2944.     {
  2945.         return $_[0];
  2946.     }
  2947. }
  2948.  
  2949. sub _tracefirst($)
  2950. {
  2951.     if (defined $::RD_TRACE
  2952.         && $::RD_TRACE =~ /\d+/
  2953.         && $::RD_TRACE>1
  2954.         && $::RD_TRACE+10<length($_[0]))
  2955.     {
  2956.         my $count = length($_[0]) - $::RD_TRACE;
  2957.         return substr($_[0],0,$::RD_TRACE) . "...<+$count>";
  2958.     }
  2959.     else
  2960.     {
  2961.         return $_[0];
  2962.     }
  2963. }
  2964.  
  2965. my $lastcontext = '';
  2966. my $lastrulename = '';
  2967. my $lastlevel = '';
  2968.  
  2969. sub _trace($;$$$)
  2970. {
  2971.     $tracemsg      = $_[0];
  2972.     $tracecontext  = $_[1]||$lastcontext;
  2973.     $tracerulename = $_[2]||$lastrulename;
  2974.     $tracelevel    = $_[3]||$lastlevel;
  2975.     if ($tracerulename) { $lastrulename = $tracerulename }
  2976.     if ($tracelevel)    { $lastlevel = $tracelevel }
  2977.  
  2978.     $tracecontext =~ s/\n/\\n/g;
  2979.     $tracecontext =~ s/\s+/ /g;
  2980.     $tracerulename = qq{$tracerulename};
  2981.     write TRACE;
  2982.     if ($tracecontext ne $lastcontext)
  2983.     {
  2984.         if ($tracecontext)
  2985.         {
  2986.             $lastcontext = _tracefirst($tracecontext);
  2987.             $tracecontext = qq{"$tracecontext"};
  2988.         }
  2989.         else
  2990.         {
  2991.             $tracecontext = qq{<NO TEXT LEFT>};
  2992.         }
  2993.         write TRACECONTEXT;
  2994.     }
  2995. }
  2996.  
  2997. sub _parseunneg($$$$)
  2998. {
  2999.     _parse($_[0],$_[1],$_[3]);
  3000.     if ($_[2]<0)
  3001.     {
  3002.         _error("Can't negate \"$&\".",$_[3]);
  3003.         _hint("You can't negate $_[0]. Remove the \"...!\" before
  3004.                \"$&\".");
  3005.         return 0;
  3006.     }
  3007.     return 1;
  3008. }
  3009.  
  3010. sub _parse($$$;$)
  3011. {
  3012.     my $what = $_[3] || $&;
  3013.        $what =~ s/^\s+//;
  3014.     if ($_[1])
  3015.     {
  3016.         _warn(3,"Found $_[0] ($what) after an unconditional <error>",$_[2])
  3017.         and
  3018.         _hint("An unconditional <error> always causes the
  3019.                production containing it to immediately fail.
  3020.                \u$_[0] that follows an <error>
  3021.                will never be reached.  Did you mean to use
  3022.                <error?> instead?");
  3023.     }
  3024.  
  3025.     return if ! _verbosity("TRACE");
  3026.     $errortext = "Treating \"$what\" as $_[0]";
  3027.     $errorprefix = "Parse::RecDescent";
  3028.     $errortext =~ s/\s+/ /g;
  3029.     write ERROR;
  3030. }
  3031.  
  3032. sub _linecount($) {
  3033.     scalar substr($_[0], pos $_[0]||0) =~ tr/\n//
  3034. }
  3035.  
  3036.  
  3037. package main;
  3038.  
  3039. use vars qw ( $RD_ERRORS $RD_WARN $RD_HINT $RD_TRACE $RD_CHECK );
  3040. $::RD_CHECK = 1;
  3041. $::RD_ERRORS = 1;
  3042. $::RD_WARN = 3;
  3043.  
  3044. 1;
  3045.  
  3046.