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