File Coverage

blib/lib/Parse/Yapp/Driver.pm
Criterion Covered Total %
statement 209 255 81.9
branch 108 156 69.2
condition 18 36 50.0
subroutine 16 24 66.6
pod 0 14 0.0
total 351 485 72.3


line stmt bran cond sub pod time code
1             #
2             # Module Parse::Yapp::Driver
3             #
4             # This module is part of the Parse::Yapp package available on your
5             # nearest CPAN
6             #
7             # Any use of this module in a standalone parser make the included
8             # text under the same copyright as the Parse::Yapp module itself.
9             #
10             # This notice should remain unchanged.
11             #
12             # Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
13             # Copyright © 2017 William N. Braswell, Jr.
14             # (see the pod text in Parse::Yapp module for use and distribution rights)
15             #
16              
17             package Parse::Yapp::Driver;
18              
19             require 5.004;
20              
21 3     3   25 use strict;
  3         6  
  3         82  
22              
23 3     3   16 use vars qw ( $VERSION $COMPATIBLE $FILENAME );
  3         6  
  3         165  
24              
25             # CORRELATION #py001: $VERSION must be changed in both Parse::Yapp & Parse::Yapp::Driver
26             $VERSION = '1.2';
27             $COMPATIBLE = '0.07';
28             $FILENAME=__FILE__;
29              
30 3     3   14 use Carp;
  3         4  
  3         2336  
31              
32             #Known parameters, all starting with YY (leading YY will be discarded)
33             my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
34             YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
35             #Mandatory parameters
36             my(@params)=('LEX','RULES','STATES');
37              
38             sub new {
39 19     19 0 4382 my($class)=shift;
40 19         42 my($errst,$nberr,$token,$value,$check,$dotpos);
41 19         116 my($self)={ ERROR => \&_Error,
42             ERRST => \$errst,
43             NBERR => \$nberr,
44             TOKEN => \$token,
45             VALUE => \$value,
46             DOTPOS => \$dotpos,
47             STACK => [],
48             DEBUG => 0,
49             CHECK => \$check };
50              
51 19         76 _CheckParams( [], \%params, \@_, $self );
52              
53             exists($$self{VERSION})
54 19 50 33     163 and $$self{VERSION} < $COMPATIBLE
55             and croak "Yapp driver version $VERSION ".
56             "incompatible with version $$self{VERSION}:\n".
57             "Please recompile parser module.";
58              
59 19 50       58 ref($class)
60             and $class=ref($class);
61              
62 19         59 bless($self,$class);
63             }
64              
65             sub YYParse {
66 22     22 0 119 my($self)=shift;
67 22         37 my($retval);
68              
69 22         65 _CheckParams( \@params, \%params, \@_, $self );
70              
71 22 100       66 if($$self{DEBUG}) {
72 1         4 _DBLoad();
73 1         56 $retval = eval '$self->_DBParse()';#Do not create stab entry on compile
74 1 50       11 $@ and die $@;
75             }
76             else {
77 21         64 $retval = $self->_Parse();
78             }
79 22         59 $retval
80             }
81              
82             sub YYData {
83 489     489 0 2507 my($self)=shift;
84              
85             exists($$self{USER})
86 489 100       1005 or $$self{USER}={};
87              
88 489         1196 $$self{USER};
89            
90             }
91              
92             sub YYErrok {
93 3     3 0 18 my($self)=shift;
94              
95 3         8 ${$$self{ERRST}}=0;
  3         6  
96 3         39 undef;
97             }
98              
99             sub YYNberr {
100 1     1 0 120 my($self)=shift;
101              
102 1         2 ${$$self{NBERR}};
  1         4  
103             }
104              
105             sub YYRecovering {
106 0     0 0 0 my($self)=shift;
107              
108 0         0 ${$$self{ERRST}} != 0;
  0         0  
109             }
110              
111             sub YYAbort {
112 0     0 0 0 my($self)=shift;
113              
114 0         0 ${$$self{CHECK}}='ABORT';
  0         0  
115 0         0 undef;
116             }
117              
118             sub YYAccept {
119 22     22 0 49 my($self)=shift;
120              
121 22         37 ${$$self{CHECK}}='ACCEPT';
  22         45  
122 22         73 undef;
123             }
124              
125             sub YYError {
126 0     0 0 0 my($self)=shift;
127              
128 0         0 ${$$self{CHECK}}='ERROR';
  0         0  
129 0         0 undef;
130             }
131              
132             sub YYSemval {
133 6     6 0 19 my($self)=shift;
134 6         10 my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
  6         12  
135              
136             $index < 0
137 6         30 and -$index <= @{$$self{STACK}}
138 6 50 33     15 and return $$self{STACK}[$index][1];
139              
140 0         0 undef; #Invalid index
141             }
142              
143             sub YYCurtok {
144 0     0 0 0 my($self)=shift;
145              
146             @_
147 0 0       0 and ${$$self{TOKEN}}=$_[0];
  0         0  
148 0         0 ${$$self{TOKEN}};
  0         0  
149             }
150              
151             sub YYCurval {
152 0     0 0 0 my($self)=shift;
153              
154             @_
155 0 0       0 and ${$$self{VALUE}}=$_[0];
  0         0  
156 0         0 ${$$self{VALUE}};
  0         0  
157             }
158              
159             sub YYExpect {
160 0     0 0 0 my($self)=shift;
161              
162 0         0 keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
  0         0  
163             }
164              
165             sub YYLexer {
166 0     0 0 0 my($self)=shift;
167              
168 0         0 $$self{LEX};
169             }
170              
171              
172             #################
173             # Private stuff #
174             #################
175              
176              
177             sub _CheckParams {
178 41     41   85 my($mandatory,$checklist,$inarray,$outhash)=@_;
179 41         66 my($prm,$value);
180 41         64 my($prmlst)={};
181              
182 41         150 while(($prm,$value)=splice(@$inarray,0,2)) {
183 101         182 $prm=uc($prm);
184 101 50       224 exists($$checklist{$prm})
185             or croak("Unknow parameter '$prm'");
186 101 50       236 ref($value) eq $$checklist{$prm}
187             or croak("Invalid value for parameter '$prm'");
188 101         259 $prm=unpack('@2A*',$prm);
189 101         340 $$outhash{$prm}=$value;
190             }
191 41         94 for (@$mandatory) {
192 66 50       204 exists($$outhash{$_})
193             or croak("Missing mandatory parameter '".lc($_)."'");
194             }
195             }
196              
197             sub _Error {
198 0     0   0 print "Parse error.\n";
199             }
200              
201             sub _DBLoad {
202             {
203 3     3   22 no strict 'refs';
  3     1   5  
  3         2026  
  1         2  
204              
205 1         7 exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
206 1 50       2 and return;
207             }
208 1         3 my($fname)=__FILE__;
209 1         3 my(@drv);
210 1 50       48 open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
211 1         29 while() {
212             /^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
213 473 100       1105 and do {
214 243         410 s/^#DBG>//;
215 243         632 push(@drv,$_);
216             }
217             }
218 1         8 close(DRV);
219              
220 1         5 $drv[0]=~s/_P/_DBP/;
221 1 100 66 1   903 eval join('',@drv);
  1 50 33 32   3  
  1 50 33     4  
  1 50 66     3  
  1 100 66     3  
  1 100 66     1  
  1 100 66     5  
  32 50 33     89  
  32 100       147  
  55 50       316  
  32 50       142  
  1 100       2  
  1 100       3  
  1 100       2  
  1 100       3  
  1 100       2  
  1 0       2  
  59 50       143  
  59 100       134  
  59 100       125  
  59 100       130  
  59 50       210  
  59 100       224  
  296 0       830  
  59 50       221  
  41 50       131  
  30 50       95  
  30 100       1254  
  41 50       173  
  18 0       44  
  18 100       63  
  59 50       184  
  56 50       153  
  28 100       105  
  28 0       84  
  1 50       4  
  1 50       13  
  0 100       0  
  0 50       0  
  28 0       100  
  28 50       99  
  28 50       69  
  28         67  
  28         55  
  28         89  
  28         198  
  28         99  
  28         63  
  28         138  
  0         0  
  0         0  
  28         129  
  55         210  
  28         133  
  28         605  
  28         112  
  1         8  
  1         27  
  27         78  
  0         0  
  0         0  
  27         117  
  27         84  
  27         122  
  27         187  
  1         4  
  1         4  
  27         128  
  27         101  
  27         89  
  0         0  
  0         0  
  3         13  
  1         3  
  1         6  
  1         9  
  1         6  
  1         4  
  1         3  
  1         4  
  3         11  
  2         10  
  0         0  
  0         0  
  2         11  
  2         6  
  3         8  
  3         32  
  3         16  
  3         47  
  3         15  
  0         0  
  0         0  
  3         16  
  3         18  
  0            
222             }
223              
224             #Note that for loading debugging version of the driver,
225             #this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
226             #So, DO NOT remove comment at end of sub !!!
227             sub _Parse {
228 21     21   42 my($self)=shift;
229              
230             my($rules,$states,$lex,$error)
231 21         59 = @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
232             my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
233 21         93 = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
234              
235             #DBG> my($debug)=$$self{DEBUG};
236             #DBG> my($dbgerror)=0;
237              
238             #DBG> my($ShowCurToken) = sub {
239             #DBG> my($tok)='>';
240             #DBG> for (split('',$$token)) {
241             #DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
242             #DBG> ? sprintf('<%02X>',ord($_))
243             #DBG> : $_;
244             #DBG> }
245             #DBG> $tok.='<';
246             #DBG> };
247              
248 21         38 $$errstatus=0;
249 21         39 $$nberror=0;
250 21         57 ($$token,$$value)=(undef,undef);
251 21         60 @$stack=( [ 0, undef ] );
252 21         46 $$check='';
253              
254 21         33 while(1) {
255 16339         22762 my($actions,$act,$stateno);
256              
257 16339         22729 $stateno=$$stack[-1][0];
258 16339         21700 $actions=$$states[$stateno];
259              
260             #DBG> print STDERR ('-' x 40),"\n";
261             #DBG> $debug & 0x2
262             #DBG> and print STDERR "In state $stateno:\n";
263             #DBG> $debug & 0x08
264             #DBG> and print STDERR "Stack:[".
265             #DBG> join(',',map { $$_[0] } @$stack).
266             #DBG> "]\n";
267              
268              
269 16339 100       28354 if (exists($$actions{ACTIONS})) {
270              
271             defined($$token)
272 6037 100       11856 or do {
273 4183         7813 ($$token,$$value)=&$lex($self);
274             #DBG> $debug & 0x01
275             #DBG> and print STDERR "Need token. Got ".&$ShowCurToken."\n";
276             };
277              
278             $act= exists($$actions{ACTIONS}{$$token})
279             ? $$actions{ACTIONS}{$$token}
280             : exists($$actions{DEFAULT})
281             ? $$actions{DEFAULT}
282 6037 100       16155 : undef;
    100          
283             }
284             else {
285 10302         14647 $act=$$actions{DEFAULT};
286             #DBG> $debug & 0x01
287             #DBG> and print STDERR "Don't need token.\n";
288             }
289              
290             defined($act)
291 16339 100       31424 and do {
292              
293             $act > 0
294 16324 100       30639 and do { #shift
295              
296             #DBG> $debug & 0x04
297             #DBG> and print STDERR "Shift and go to state $act.\n";
298              
299             $$errstatus
300 4171 100       7805 and do {
301 3         9 --$$errstatus;
302              
303             #DBG> $debug & 0x10
304             #DBG> and $dbgerror
305             #DBG> and $$errstatus == 0
306             #DBG> and do {
307             #DBG> print STDERR "**End of Error recovery.\n";
308             #DBG> $dbgerror=0;
309             #DBG> };
310             };
311              
312              
313 4171         7494 push(@$stack,[ $act, $$value ]);
314              
315 4171 100       9307 $$token ne '' #Don't eat the eof
316             and $$token=$$value=undef;
317 4171         6246 next;
318             };
319              
320             #reduce
321 12153         17282 my($lhs,$len,$code,@sempar,$semval);
322 12153         15570 ($lhs,$len,$code)=@{$$rules[-$act]};
  12153         22478  
323              
324             #DBG> $debug & 0x04
325             #DBG> and $act
326             #DBG> and print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
327              
328 12153 100       23794 $act
329             or $self->YYAccept();
330              
331 12153         15955 $$dotpos=$len;
332              
333             unpack('A1',$lhs) eq '@' #In line rule
334 12153 100       30966 and do {
335 3 50       14 $lhs =~ /^\@[0-9]+\-([0-9]+)$/
336             or die "In line rule name '$lhs' ill formed: ".
337             "report it as a BUG.\n";
338 3         7 $$dotpos = $1;
339             };
340              
341             @sempar = $$dotpos
342 12153 100       28150 ? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
  16311         31578  
343             : ();
344              
345 12153 100       29344 $semval = $code ? &$code( $self, @sempar )
    100          
346             : @sempar ? $sempar[0] : undef;
347              
348 12153         19653 splice(@$stack,-$len,$len);
349              
350             $$check eq 'ACCEPT'
351 12153 100       25982 and do {
352              
353             #DBG> $debug & 0x04
354             #DBG> and print STDERR "Accept.\n";
355              
356 21         72 return($semval);
357             };
358              
359             $$check eq 'ABORT'
360 12132 50       22671 and do {
361              
362             #DBG> $debug & 0x04
363             #DBG> and print STDERR "Abort.\n";
364              
365 0         0 return(undef);
366              
367             };
368              
369             #DBG> $debug & 0x04
370             #DBG> and print STDERR "Back to state $$stack[-1][0], then ";
371              
372             $$check eq 'ERROR'
373 12132 50       23170 or do {
374             #DBG> $debug & 0x04
375             #DBG> and print STDERR
376             #DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
377              
378             #DBG> $debug & 0x10
379             #DBG> and $dbgerror
380             #DBG> and $$errstatus == 0
381             #DBG> and do {
382             #DBG> print STDERR "**End of Error recovery.\n";
383             #DBG> $dbgerror=0;
384             #DBG> };
385              
386             push(@$stack,
387 12132         25999 [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
388 12132         18566 $$check='';
389 12132         20640 next;
390             };
391              
392             #DBG> $debug & 0x04
393             #DBG> and print STDERR "Forced Error recovery.\n";
394              
395 0         0 $$check='';
396              
397             };
398              
399             #Error
400             $$errstatus
401 15 100       34 or do {
402              
403 3         7 $$errstatus = 1;
404 3         9 &$error($self);
405 3 50       9 $$errstatus # if 0, then YYErrok has been called
406             or next; # so continue parsing
407              
408             #DBG> $debug & 0x10
409             #DBG> and do {
410             #DBG> print STDERR "**Entering Error recovery.\n";
411             #DBG> ++$dbgerror;
412             #DBG> };
413              
414 3         6 ++$$nberror;
415              
416             };
417              
418             $$errstatus == 3 #The next token is not valid: discard it
419 15 100       42 and do {
420             $$token eq '' # End of input: no hope
421 12 50       26 and do {
422             #DBG> $debug & 0x10
423             #DBG> and print STDERR "**At eof: aborting.\n";
424 0         0 return(undef);
425             };
426              
427             #DBG> $debug & 0x10
428             #DBG> and print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
429              
430 12         18 $$token=$$value=undef;
431             };
432              
433 15         22 $$errstatus=3;
434              
435 15   66     86 while( @$stack
      33        
436             and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
437             or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
438             or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
439              
440             #DBG> $debug & 0x10
441             #DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
442              
443 16         118 pop(@$stack);
444             }
445              
446             @$stack
447 15 50       34 or do {
448              
449             #DBG> $debug & 0x10
450             #DBG> and print STDERR "**No state left on stack: aborting.\n";
451              
452 0         0 return(undef);
453             };
454              
455             #shift the error token
456              
457             #DBG> $debug & 0x10
458             #DBG> and print STDERR "**Shift \$error token and go to state ".
459             #DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
460             #DBG> ".\n";
461              
462 15         33 push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
463              
464             }
465              
466             #never reached
467 0         0 croak("Error in driver logic. Please, report it as a BUG");
468              
469             }#_Parse
470             #DO NOT remove comment
471              
472             1;
473