## Module Parse::Yapp::Driver## This module is part of the Parse::Yapp package available on your# nearest CPAN## Any use of this module in a standalone parser make the included# text under the same copyright as the Parse::Yapp module itself.## This notice should remain unchanged.## (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.# (see the pod text in Parse::Yapp module for use and distribution rights)#package Parse::Yapp::Driver;require 5.004;use strict;use vars qw ( $VERSION $COMPATIBLE $FILENAME );$VERSION = '1.05';$COMPATIBLE = '0.07';$FILENAME=__FILE__;use Carp;#Known parameters, all starting with YY (leading YY will be discarded)my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',			 YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');#Mandatory parametersmy(@params)=('LEX','RULES','STATES');sub new {    my($class)=shift;	my($errst,$nberr,$token,$value,$check,$dotpos);    my($self)={ ERROR => \&_Error,				ERRST => \$errst,                NBERR => \$nberr,				TOKEN => \$token,				VALUE => \$value,				DOTPOS => \$dotpos,				STACK => [],				DEBUG => 0,				CHECK => \$check };	_CheckParams( [], \%params, \@_, $self );		exists($$self{VERSION})	and	$$self{VERSION} < $COMPATIBLE	and	croak "Yapp driver version $VERSION ".			  "incompatible with version $$self{VERSION}:\n".			  "Please recompile parser module.";        ref($class)    and $class=ref($class);    bless($self,$class);}sub YYParse {    my($self)=shift;    my($retval);	_CheckParams( \@params, \%params, \@_, $self );	if($$self{DEBUG}) {		_DBLoad();		$retval = eval '$self->_DBParse()';#Do not create stab entry on compile        $@ and die $@;	}	else {		$retval = $self->_Parse();	}    $retval}sub YYData {	my($self)=shift;		exists($$self{USER})	or	$$self{USER}={};	$$self{USER};	}sub YYErrok {	my($self)=shift;	${$$self{ERRST}}=0;    undef;}sub YYNberr {	my($self)=shift;	${$$self{NBERR}};}sub YYRecovering {	my($self)=shift;	${$$self{ERRST}} != 0;}sub YYAbort {	my($self)=shift;	${$$self{CHECK}}='ABORT';    undef;}sub YYAccept {	my($self)=shift;	${$$self{CHECK}}='ACCEPT';    undef;}sub YYError {	my($self)=shift;	${$$self{CHECK}}='ERROR';    undef;}sub YYSemval {	my($self)=shift;	my($index)= $_[0] - ${$$self{DOTPOS}} - 1;		$index < 0	and	-$index <= @{$$self{STACK}}	and	return $$self{STACK}[$index][1];	undef;	#Invalid index}sub YYCurtok {	my($self)=shift;        @_    and ${$$self{TOKEN}}=$_[0];    ${$$self{TOKEN}};}sub YYCurval {	my($self)=shift;        @_    and ${$$self{VALUE}}=$_[0];    ${$$self{VALUE}};}sub YYExpect {    my($self)=shift;    keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}}sub YYLexer {    my($self)=shift;	$$self{LEX};}################## Private stuff ##################sub _CheckParams {	my($mandatory,$checklist,$inarray,$outhash)=@_;	my($prm,$value);	my($prmlst)={};	while(($prm,$value)=splice(@$inarray,0,2)) {        $prm=uc($prm);			exists($$checklist{$prm})		or	croak("Unknow parameter '$prm'");			ref($value) eq $$checklist{$prm}		or	croak("Invalid value for parameter '$prm'");        $prm=unpack('@2A*',$prm);		$$outhash{$prm}=$value;	}	for (@$mandatory) {			exists($$outhash{$_})		or	croak("Missing mandatory parameter '".lc($_)."'");	}}sub _Error {	print "Parse error.\n";}sub _DBLoad {	{		no strict 'refs';			exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?		and	return;	}	my($fname)=__FILE__;	my(@drv);	open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";	while(<DRV>) {                	/^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/        	and     do {                	s/^#DBG>//;                	push(@drv,$_);        	}	}	close(DRV);	$drv[0]=~s/_P/_DBP/;	eval join('',@drv);}#Note that for loading debugging version of the driver,#this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.#So, DO NOT remove comment at end of sub !!!sub _Parse {    my($self)=shift;	my($rules,$states,$lex,$error)     = @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };	my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)     = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };#DBG>	my($debug)=$$self{DEBUG};#DBG>	my($dbgerror)=0;#DBG>	my($ShowCurToken) = sub {#DBG>		my($tok)='>';#DBG>		for (split('',$$token)) {#DBG>			$tok.=		(ord($_) < 32 or ord($_) > 126)#DBG>					?	sprintf('<%02X>',ord($_))#DBG>					:	$_;#DBG>		}#DBG>		$tok.='<';#DBG>	};	$$errstatus=0;	$$nberror=0;	($$token,$$value)=(undef,undef);	@$stack=( [ 0, undef ] );	$$check='';    while(1) {        my($actions,$act,$stateno);        $stateno=$$stack[-1][0];        $actions=$$states[$stateno];#DBG>	print STDERR ('-' x 40),"\n";#DBG>		$debug & 0x2#DBG>	and	print STDERR "In state $stateno:\n";#DBG>		$debug & 0x08#DBG>	and	print STDERR "Stack:[".#DBG>					 join(',',map { $$_[0] } @$stack).#DBG>					 "]\n";        if  (exists($$actions{ACTIONS})) {				defined($$token)            or	do {				($$token,$$value)=&$lex($self);#DBG>				$debug & 0x01#DBG>			and	print STDERR "Need token. Got ".&$ShowCurToken."\n";			};            $act=   exists($$actions{ACTIONS}{$$token})                    ?   $$actions{ACTIONS}{$$token}                    :   exists($$actions{DEFAULT})                        ?   $$actions{DEFAULT}                        :   undef;        }        else {            $act=$$actions{DEFAULT};#DBG>			$debug & 0x01#DBG>		and	print STDERR "Don't need token.\n";        }            defined($act)        and do {                $act > 0            and do {        #shift#DBG>				$debug & 0x04#DBG>			and	print STDERR "Shift and go to state $act.\n";					$$errstatus				and	do {					--$$errstatus;#DBG>					$debug & 0x10#DBG>				and	$dbgerror#DBG>				and	$$errstatus == 0#DBG>				and	do {#DBG>					print STDERR "**End of Error recovery.\n";#DBG>					$dbgerror=0;#DBG>				};				};                push(@$stack,[ $act, $$value ]);					$$token ne ''	#Don't eat the eof				and	$$token=$$value=undef;                next;            };            #reduce            my($lhs,$len,$code,@sempar,$semval);            ($lhs,$len,$code)=@{$$rules[-$act]};#DBG>			$debug & 0x04#DBG>		and	$act#DBG>		and	print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";                $act            or  $self->YYAccept();            $$dotpos=$len;                unpack('A1',$lhs) eq '@'    #In line rule            and do {                    $lhs =~ /^\@[0-9]+\-([0-9]+)$/                or  die "In line rule name '$lhs' ill formed: ".                        "report it as a BUG.\n";                $$dotpos = $1;            };            @sempar =       $$dotpos                        ?   map { $$_[1] } @$stack[ -$$dotpos .. -1 ]                        :   ();            $semval = $code ? &$code( $self, @sempar )                            : @sempar ? $sempar[0] : undef;            splice(@$stack,-$len,$len);                $$check eq 'ACCEPT'            and do {#DBG>			$debug & 0x04#DBG>		and	print STDERR "Accept.\n";				return($semval);			};                $$check eq 'ABORT'            and	do {#DBG>			$debug & 0x04#DBG>		and	print STDERR "Abort.\n";				return(undef);			};#DBG>			$debug & 0x04#DBG>		and	print STDERR "Back to state $$stack[-1][0], then ";                $$check eq 'ERROR'            or  do {#DBG>				$debug & 0x04#DBG>			and	print STDERR #DBG>				    "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";#DBG>				$debug & 0x10#DBG>			and	$dbgerror#DBG>			and	$$errstatus == 0#DBG>			and	do {#DBG>				print STDERR "**End of Error recovery.\n";#DBG>				$dbgerror=0;#DBG>			};			    push(@$stack,                     [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);                $$check='';                next;            };#DBG>			$debug & 0x04#DBG>		and	print STDERR "Forced Error recovery.\n";            $$check='';        };        #Error            $$errstatus        or   do {            $$errstatus = 1;            &$error($self);                $$errstatus # if 0, then YYErrok has been called            or  next;       # so continue parsing#DBG>			$debug & 0x10#DBG>		and	do {#DBG>			print STDERR "**Entering Error recovery.\n";#DBG>			++$dbgerror;#DBG>		};            ++$$nberror;        };			$$errstatus == 3	#The next token is not valid: discard it		and	do {				$$token eq ''	# End of input: no hope			and	do {#DBG>				$debug & 0x10#DBG>			and	print STDERR "**At eof: aborting.\n";				return(undef);			};#DBG>			$debug & 0x10#DBG>		and	print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";			$$token=$$value=undef;		};        $$errstatus=3;		while(	  @$stack			  and (		not exists($$states[$$stack[-1][0]]{ACTIONS})			        or  not exists($$states[$$stack[-1][0]]{ACTIONS}{error})					or	$$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {#DBG>			$debug & 0x10#DBG>		and	print STDERR "**Pop state $$stack[-1][0].\n";			pop(@$stack);		}			@$stack		or	do {#DBG>			$debug & 0x10#DBG>		and	print STDERR "**No state left on stack: aborting.\n";			return(undef);		};		#shift the error token#DBG>			$debug & 0x10#DBG>		and	print STDERR "**Shift \$error token and go to state ".#DBG>						 $$states[$$stack[-1][0]]{ACTIONS}{error}.#DBG>						 ".\n";		push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);    }    #never reached	croak("Error in driver logic. Please, report it as a BUG");}#_Parse#DO NOT remove comment1;