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