File Coverage

blib/lib/Data/SExpression/Parser.pm
Criterion Covered Total %
statement 94 166 56.6
branch 34 72 47.2
condition 1 12 8.3
subroutine 13 24 54.1
pod n/a
total 142 274 51.8


line stmt bran cond sub pod time code
1             ####################################################################
2             #
3             # This file was generated using Parse::Yapp version 1.05.
4             #
5             # Don't edit this file, use source file instead.
6             #
7             # ANY CHANGE MADE HERE WILL BE LOST !
8             #
9             ####################################################################
10             package Data::SExpression::Parser;
11 9     9   18994 use vars qw ( @ISA );
  9         18  
  9         542  
12 9     9   52 use strict;
  9         17  
  9         702  
13              
14             @ISA= qw ( Parse::Yapp::Driver );
15             #Included Parse/Yapp/Driver.pm file----------------------------------------
16             {
17             #
18             # Module Parse::Yapp::Driver
19             #
20             # This module is part of the Parse::Yapp package available on your
21             # nearest CPAN
22             #
23             # Any use of this module in a standalone parser make the included
24             # text under the same copyright as the Parse::Yapp module itself.
25             #
26             # This notice should remain unchanged.
27             #
28             # (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
29             # (see the pod text in Parse::Yapp module for use and distribution rights)
30             #
31              
32             package Parse::Yapp::Driver;
33              
34             require 5.004;
35              
36 9     9   46 use strict;
  9         16  
  9         277  
37              
38 9     9   148 use vars qw ( $VERSION $COMPATIBLE $FILENAME );
  9         27  
  9         744  
39              
40             $VERSION = '1.05';
41             $COMPATIBLE = '0.07';
42             $FILENAME=__FILE__;
43              
44 9     9   49 use Carp;
  9         15  
  9         10609  
45              
46             #Known parameters, all starting with YY (leading YY will be discarded)
47             my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
48             YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
49             #Mandatory parameters
50             my(@params)=('LEX','RULES','STATES');
51              
52             sub new {
53 24     24   52 my($class)=shift;
54 24         38 my($errst,$nberr,$token,$value,$check,$dotpos);
55 24         211 my($self)={ ERROR => \&_Error,
56             ERRST => \$errst,
57             NBERR => \$nberr,
58             TOKEN => \$token,
59             VALUE => \$value,
60             DOTPOS => \$dotpos,
61             STACK => [],
62             DEBUG => 0,
63             CHECK => \$check };
64              
65 24         109 _CheckParams( [], \%params, \@_, $self );
66              
67 24 50 33     210 exists($$self{VERSION})
68             and $$self{VERSION} < $COMPATIBLE
69             and croak "Yapp driver version $VERSION ".
70             "incompatible with version $$self{VERSION}:\n".
71             "Please recompile parser module.";
72              
73 24 50       69 ref($class)
74             and $class=ref($class);
75              
76 24         120 bless($self,$class);
77             }
78              
79             sub YYParse {
80 54     54   80 my($self)=shift;
81 54         60 my($retval);
82              
83 54         162 _CheckParams( \@params, \%params, \@_, $self );
84              
85 54 50       155 if($$self{DEBUG}) {
86 0         0 _DBLoad();
87 0         0 $retval = eval '$self->_DBParse()';#Do not create stab entry on compile
88 0 0       0 $@ and die $@;
89             }
90             else {
91 54         204 $retval = $self->_Parse();
92             }
93 53         338 $retval
94             }
95              
96             sub YYData {
97 1001     1001   1226 my($self)=shift;
98              
99 1001 100       2078 exists($$self{USER})
100             or $$self{USER}={};
101              
102 1001         3366 $$self{USER};
103            
104             }
105              
106             sub YYErrok {
107 0     0   0 my($self)=shift;
108              
109 0         0 ${$$self{ERRST}}=0;
  0         0  
110 0         0 undef;
111             }
112              
113             sub YYNberr {
114 0     0   0 my($self)=shift;
115              
116 0         0 ${$$self{NBERR}};
  0         0  
117             }
118              
119             sub YYRecovering {
120 0     0   0 my($self)=shift;
121              
122 0         0 ${$$self{ERRST}} != 0;
  0         0  
123             }
124              
125             sub YYAbort {
126 0     0   0 my($self)=shift;
127              
128 0         0 ${$$self{CHECK}}='ABORT';
  0         0  
129 0         0 undef;
130             }
131              
132             sub YYAccept {
133 53     53   77 my($self)=shift;
134              
135 53         68 ${$$self{CHECK}}='ACCEPT';
  53         259  
136 53         98 undef;
137             }
138              
139             sub YYError {
140 0     0   0 my($self)=shift;
141              
142 0         0 ${$$self{CHECK}}='ERROR';
  0         0  
143 0         0 undef;
144             }
145              
146             sub YYSemval {
147 0     0   0 my($self)=shift;
148 0         0 my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
  0         0  
149              
150 0         0 $index < 0
151 0 0 0     0 and -$index <= @{$$self{STACK}}
152             and return $$self{STACK}[$index][1];
153              
154 0         0 undef; #Invalid index
155             }
156              
157             sub YYCurtok {
158 0     0   0 my($self)=shift;
159              
160             @_
161 0 0       0 and ${$$self{TOKEN}}=$_[0];
  0         0  
162 0         0 ${$$self{TOKEN}};
  0         0  
163             }
164              
165             sub YYCurval {
166 0     0   0 my($self)=shift;
167              
168             @_
169 0 0       0 and ${$$self{VALUE}}=$_[0];
  0         0  
170 0         0 ${$$self{VALUE}};
  0         0  
171             }
172              
173             sub YYExpect {
174 0     0   0 my($self)=shift;
175              
176 0         0 keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
  0         0  
177             }
178              
179             sub YYLexer {
180 1     1   2 my($self)=shift;
181              
182 1         4 $$self{LEX};
183             }
184              
185              
186             #################
187             # Private stuff #
188             #################
189              
190              
191             sub _CheckParams {
192 78     78   138 my($mandatory,$checklist,$inarray,$outhash)=@_;
193 78         91 my($prm,$value);
194 78         125 my($prmlst)={};
195              
196 78         325 while(($prm,$value)=splice(@$inarray,0,2)) {
197 180         327 $prm=uc($prm);
198 180 50       399 exists($$checklist{$prm})
199             or croak("Unknow parameter '$prm'");
200 180 50       442 ref($value) eq $$checklist{$prm}
201             or croak("Invalid value for parameter '$prm'");
202 180         578 $prm=unpack('@2A*',$prm);
203 180         650 $$outhash{$prm}=$value;
204             }
205 78         181 for (@$mandatory) {
206 162 50       434 exists($$outhash{$_})
207             or croak("Missing mandatory parameter '".lc($_)."'");
208             }
209             }
210              
211             sub _Error {
212 0     0   0 print "Parse error.\n";
213             }
214              
215             sub _DBLoad {
216             {
217 9     9   57 no strict 'refs';
  9     0   17  
  9         12555  
  0         0  
218              
219 0 0       0 exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
  0         0  
220             and return;
221             }
222 0         0 my($fname)=__FILE__;
223 0         0 my(@drv);
224 0 0       0 open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
225 0         0 while() {
226             /^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
227 0 0       0 and do {
228 0         0 s/^#DBG>//;
229 0         0 push(@drv,$_);
230             }
231             }
232 0         0 close(DRV);
233              
234 0         0 $drv[0]=~s/_P/_DBP/;
235 0         0 eval join('',@drv);
236             }
237              
238             #Note that for loading debugging version of the driver,
239             #this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
240             #So, DO NOT remove comment at end of sub !!!
241             sub _Parse {
242 54     54   85 my($self)=shift;
243              
244 54         141 my($rules,$states,$lex,$error)
245             = @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
246 54         150 my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
247             = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
248              
249             #DBG> my($debug)=$$self{DEBUG};
250             #DBG> my($dbgerror)=0;
251              
252             #DBG> my($ShowCurToken) = sub {
253             #DBG> my($tok)='>';
254             #DBG> for (split('',$$token)) {
255             #DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
256             #DBG> ? sprintf('<%02X>',ord($_))
257             #DBG> : $_;
258             #DBG> }
259             #DBG> $tok.='<';
260             #DBG> };
261              
262 54         79 $$errstatus=0;
263 54         58 $$nberror=0;
264 54         83 ($$token,$$value)=(undef,undef);
265 54         164 @$stack=( [ 0, undef ] );
266 54         84 $$check='';
267              
268 54         59 while(1) {
269 650         779 my($actions,$act,$stateno);
270              
271 650         888 $stateno=$$stack[-1][0];
272 650         694 $actions=$$states[$stateno];
273              
274             #DBG> print STDERR ('-' x 40),"\n";
275             #DBG> $debug & 0x2
276             #DBG> and print STDERR "In state $stateno:\n";
277             #DBG> $debug & 0x08
278             #DBG> and print STDERR "Stack:[".
279             #DBG> join(',',map { $$_[0] } @$stack).
280             #DBG> "]\n";
281              
282              
283 650 100       1579 if (exists($$actions{ACTIONS})) {
284              
285             defined($$token)
286 294 100       557 or do {
287 247         546 ($$token,$$value)=&$lex($self);
288             #DBG> $debug & 0x01
289             #DBG> and print STDERR "Need token. Got ".&$ShowCurToken."\n";
290             };
291              
292 294 100       1100 $act= exists($$actions{ACTIONS}{$$token})
    100          
293             ? $$actions{ACTIONS}{$$token}
294             : exists($$actions{DEFAULT})
295             ? $$actions{DEFAULT}
296             : undef;
297             }
298             else {
299 356         463 $act=$$actions{DEFAULT};
300             #DBG> $debug & 0x01
301             #DBG> and print STDERR "Don't need token.\n";
302             }
303              
304             defined($act)
305 650 100       1168 and do {
306              
307             $act > 0
308 649 100       3504 and do { #shift
309              
310             #DBG> $debug & 0x04
311             #DBG> and print STDERR "Shift and go to state $act.\n";
312              
313             $$errstatus
314 246 50       429 and do {
315 0         0 --$$errstatus;
316              
317             #DBG> $debug & 0x10
318             #DBG> and $dbgerror
319             #DBG> and $$errstatus == 0
320             #DBG> and do {
321             #DBG> print STDERR "**End of Error recovery.\n";
322             #DBG> $dbgerror=0;
323             #DBG> };
324             };
325              
326              
327 246         551 push(@$stack,[ $act, $$value ]);
328              
329 246 50       562 $$token ne '' #Don't eat the eof
330             and $$token=$$value=undef;
331 246         510 next;
332             };
333              
334             #reduce
335 403         409 my($lhs,$len,$code,@sempar,$semval);
336 403         530 ($lhs,$len,$code)=@{$$rules[-$act]};
  403         876  
337              
338             #DBG> $debug & 0x04
339             #DBG> and $act
340             #DBG> and print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
341              
342 403 50       756 $act
343             or $self->YYAccept();
344              
345 403         531 $$dotpos=$len;
346              
347             unpack('A1',$lhs) eq '@' #In line rule
348 403 50       1426 and do {
349 0 0       0 $lhs =~ /^\@[0-9]+\-([0-9]+)$/
350             or die "In line rule name '$lhs' ill formed: ".
351             "report it as a BUG.\n";
352 0         0 $$dotpos = $1;
353             };
354              
355 596         1682 @sempar = $$dotpos
356 403 100       1237 ? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
357             : ();
358              
359 403 50       1549 $semval = $code ? &$code( $self, @sempar )
    100          
360             : @sempar ? $sempar[0] : undef;
361              
362 403         3310 splice(@$stack,-$len,$len);
363              
364             $$check eq 'ACCEPT'
365 403 100       947 and do {
366              
367             #DBG> $debug & 0x04
368             #DBG> and print STDERR "Accept.\n";
369              
370 53         330 return($semval);
371             };
372              
373             $$check eq 'ABORT'
374 350 50       582 and do {
375              
376             #DBG> $debug & 0x04
377             #DBG> and print STDERR "Abort.\n";
378              
379 0         0 return(undef);
380              
381             };
382              
383             #DBG> $debug & 0x04
384             #DBG> and print STDERR "Back to state $$stack[-1][0], then ";
385              
386             $$check eq 'ERROR'
387 350 50       752 or do {
388             #DBG> $debug & 0x04
389             #DBG> and print STDERR
390             #DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
391              
392             #DBG> $debug & 0x10
393             #DBG> and $dbgerror
394             #DBG> and $$errstatus == 0
395             #DBG> and do {
396             #DBG> print STDERR "**End of Error recovery.\n";
397             #DBG> $dbgerror=0;
398             #DBG> };
399              
400 350         1073 push(@$stack,
401             [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
402 350         454 $$check='';
403 350         628 next;
404             };
405              
406             #DBG> $debug & 0x04
407             #DBG> and print STDERR "Forced Error recovery.\n";
408              
409 0         0 $$check='';
410              
411             };
412              
413             #Error
414             $$errstatus
415 1 50       4 or do {
416              
417 1         2 $$errstatus = 1;
418 1         4 &$error($self);
419 0 0         $$errstatus # if 0, then YYErrok has been called
420             or next; # so continue parsing
421              
422             #DBG> $debug & 0x10
423             #DBG> and do {
424             #DBG> print STDERR "**Entering Error recovery.\n";
425             #DBG> ++$dbgerror;
426             #DBG> };
427              
428 0           ++$$nberror;
429              
430             };
431              
432             $$errstatus == 3 #The next token is not valid: discard it
433 0 0         and do {
434             $$token eq '' # End of input: no hope
435 0 0         and do {
436             #DBG> $debug & 0x10
437             #DBG> and print STDERR "**At eof: aborting.\n";
438 0           return(undef);
439             };
440              
441             #DBG> $debug & 0x10
442             #DBG> and print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
443              
444 0           $$token=$$value=undef;
445             };
446              
447 0           $$errstatus=3;
448              
449 0   0       while( @$stack
      0        
450             and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
451             or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
452             or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
453              
454             #DBG> $debug & 0x10
455             #DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
456              
457 0           pop(@$stack);
458             }
459              
460             @$stack
461 0 0         or do {
462              
463             #DBG> $debug & 0x10
464             #DBG> and print STDERR "**No state left on stack: aborting.\n";
465              
466 0           return(undef);
467             };
468              
469             #shift the error token
470              
471             #DBG> $debug & 0x10
472             #DBG> and print STDERR "**Shift \$error token and go to state ".
473             #DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
474             #DBG> ".\n";
475              
476 0           push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
477              
478             }
479              
480             #never reached
481 0           croak("Error in driver logic. Please, report it as a BUG");
482              
483             }#_Parse
484             #DO NOT remove comment
485              
486             1;
487              
488             }
489             #End of include--------------------------------------------------
490              
491              
492             #line 9 "lib/Data/SExpression/Parser.yp"
493              
494             use Data::SExpression::Cons;
495             use Scalar::Util qw(weaken);
496              
497              
498             sub new {
499             my($class)=shift;
500             ref($class)
501             and $class=ref($class);
502              
503             my($self)=$class->SUPER::new( yyversion => '1.05',
504             yystates =>
505             [
506             {#State 0
507             ACTIONS => {
508             "(" => 5,
509             'SYMBOL' => 1,
510             'NUMBER' => 8,
511             'STRING' => 4,
512             'QUOTE' => 3
513             },
514             GOTOS => {
515             'expression' => 7,
516             'sexpression' => 6,
517             'quoted' => 2,
518             'list' => 9
519             }
520             },
521             {#State 1
522             DEFAULT => -3
523             },
524             {#State 2
525             DEFAULT => -6
526             },
527             {#State 3
528             ACTIONS => {
529             "(" => 5,
530             'SYMBOL' => 1,
531             'NUMBER' => 8,
532             'STRING' => 4,
533             'QUOTE' => 3
534             },
535             GOTOS => {
536             'expression' => 10,
537             'quoted' => 2,
538             'list' => 9
539             }
540             },
541             {#State 4
542             DEFAULT => -4
543             },
544             {#State 5
545             ACTIONS => {
546             "(" => 5,
547             'SYMBOL' => 1,
548             'NUMBER' => 8,
549             'STRING' => 4,
550             'QUOTE' => 3
551             },
552             DEFAULT => -11,
553             GOTOS => {
554             'expression' => 11,
555             'quoted' => 2,
556             'list_interior' => 12,
557             'list' => 9
558             }
559             },
560             {#State 6
561             ACTIONS => {
562             '' => 13
563             }
564             },
565             {#State 7
566             DEFAULT => -1
567             },
568             {#State 8
569             DEFAULT => -2
570             },
571             {#State 9
572             DEFAULT => -5
573             },
574             {#State 10
575             DEFAULT => -12
576             },
577             {#State 11
578             ACTIONS => {
579             'SYMBOL' => 1,
580             'STRING' => 4,
581             'QUOTE' => 3,
582             "(" => 5,
583             'NUMBER' => 8,
584             "." => 15
585             },
586             DEFAULT => -10,
587             GOTOS => {
588             'expression' => 11,
589             'quoted' => 2,
590             'list_interior' => 14,
591             'list' => 9
592             }
593             },
594             {#State 12
595             ACTIONS => {
596             ")" => 16
597             }
598             },
599             {#State 13
600             DEFAULT => 0
601             },
602             {#State 14
603             DEFAULT => -9
604             },
605             {#State 15
606             ACTIONS => {
607             "(" => 5,
608             'SYMBOL' => 1,
609             'NUMBER' => 8,
610             'STRING' => 4,
611             'QUOTE' => 3
612             },
613             GOTOS => {
614             'expression' => 17,
615             'quoted' => 2,
616             'list' => 9
617             }
618             },
619             {#State 16
620             DEFAULT => -7
621             },
622             {#State 17
623             DEFAULT => -8
624             }
625             ],
626             yyrules =>
627             [
628             [#Rule 0
629             '$start', 2, undef
630             ],
631             [#Rule 1
632             'sexpression', 1,
633             sub
634             #line 16 "lib/Data/SExpression/Parser.yp"
635             { $_[0]->YYAccept; return $_[1]; }
636             ],
637             [#Rule 2
638             'expression', 1, undef
639             ],
640             [#Rule 3
641             'expression', 1,
642             sub
643             #line 20 "lib/Data/SExpression/Parser.yp"
644             { $_[0]->handler->new_symbol($_[1]) }
645             ],
646             [#Rule 4
647             'expression', 1,
648             sub
649             #line 21 "lib/Data/SExpression/Parser.yp"
650             { $_[0]->handler->new_string($_[1]) }
651             ],
652             [#Rule 5
653             'expression', 1, undef
654             ],
655             [#Rule 6
656             'expression', 1, undef
657             ],
658             [#Rule 7
659             'list', 3,
660             sub
661             #line 27 "lib/Data/SExpression/Parser.yp"
662             { $_[2] }
663             ],
664             [#Rule 8
665             'list_interior', 3,
666             sub
667             #line 32 "lib/Data/SExpression/Parser.yp"
668             { $_[0]->handler->new_cons($_[1], $_[3]) }
669             ],
670             [#Rule 9
671             'list_interior', 2,
672             sub
673             #line 33 "lib/Data/SExpression/Parser.yp"
674             { $_[0]->handler->new_cons($_[1], $_[2]) }
675             ],
676             [#Rule 10
677             'list_interior', 1,
678             sub
679             #line 34 "lib/Data/SExpression/Parser.yp"
680             { $_[0]->handler->new_cons($_[1], undef) }
681             ],
682             [#Rule 11
683             'list_interior', 0,
684             sub
685             #line 35 "lib/Data/SExpression/Parser.yp"
686             { undef }
687             ],
688             [#Rule 12
689             'quoted', 2,
690             sub
691             #line 40 "lib/Data/SExpression/Parser.yp"
692             { $_[0]->handler->new_cons($_[0]->handler->new_symbol($_[1]),
693             $_[0]->handler->new_cons($_[2], undef))}
694             ]
695             ],
696             @_);
697             bless($self,$class);
698             }
699              
700             #line 44 "lib/Data/SExpression/Parser.yp"
701              
702              
703             sub set_input {
704             my $self = shift;
705             my $input = shift;
706             die(__PACKAGE__ . "::set_input called with 0 arguments") unless defined($input);
707             $self->YYData->{INPUT} = $input;
708             }
709              
710             sub set_handler {
711             my $self = shift;
712             my $handler = shift or die(__PACKAGE__ . "::set_handler called with 0 arguments");
713             $self->YYData->{HANDLER} = $handler;
714             weaken $self->YYData->{HANDLER};
715             }
716              
717             sub handler {
718             my $self = shift;
719             return $self->YYData->{HANDLER};
720             }
721              
722             sub unparsed_input {
723             my $self = shift;
724             return substr($self->YYData->{INPUT}, pos($self->YYData->{INPUT}));
725             }
726              
727              
728             my %quotes = (q{'} => 'quote',
729             q{`} => 'quasiquote',
730             q{,} => 'unquote');
731              
732              
733             sub lexer {
734             my $self = shift;
735              
736             defined($self->YYData->{INPUT}) or return ('', undef);
737              
738             my $symbol_char = qr{[*!\$[:alpha:]\?<>=/+:_{}-]};
739              
740             for($self->YYData->{INPUT}) {
741             $_ =~ /\G \s* (?: ; .* \s* )* /gcx;
742              
743             /\G ([+-]? \d+ (?:[.]\d*)?) /gcx
744             || /\G ([+-]? [.] \d+) /gcx
745             and return ('NUMBER', $1);
746              
747             /\G ($symbol_char ($symbol_char | \d | [.] )*)/gcx
748             and return ('SYMBOL', $1);
749              
750             /\G (\| [^|]* \|) /gcx
751             and return ('SYMBOL', $1);
752              
753             /\G " ([^"\\]* (?: \\. [^"\\]*)*) "/gcx
754             and return ('STRING', defined($1) ? $1 : "");
755              
756             /\G ([().])/gcx
757             and return ($1, $1);
758              
759             /\G ([`',]) /gcx
760             and return ('QUOTE', $quotes{$1});
761              
762             return ('', undef);
763             }
764             }
765              
766             sub error {
767             my $self = shift;
768             my ($tok, $val) = $self->YYLexer->($self);
769             die("Parse error near: '" . $self->unparsed_input . "'");
770             return undef;
771             }
772              
773             sub parse {
774             my $self = shift;
775             return $self->YYParse(yylex => \&lexer, yyerror => \&error);
776             }
777              
778             1;