source4/build/pidl/lib/Parse/RecDescent.pm

   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