File Coverage

blib/lib/Parse/RecDescent.pm
Criterion Covered Total %
statement 3915 4699 83.3
branch 1141 2478 46.0
condition 398 1004 39.6
subroutine 244 245 99.5
pod 0 8 0.0
total 5698 8434 67.5


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