recdescent.pm

来自「视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.」· PM 代码 · 共 2,532 行 · 第 1/5 页

		$return = $item[-1];
	';
}

package Parse::RecDescent::Operator;

my @opertype = ( " non-optional", "n optional" );

sub issubrule { 0 }
sub isterminal { 0 }

sub describe { $_[0]->{"expected"} }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} .  '__'; }


sub new
{
	my ($class, $type, $minrep, $maxrep, $leftarg, $op, $rightarg) = @_;

	bless 
	{
		"type"      => "${type}op",
		"leftarg"   => $leftarg,
		"op"        => $op,
		"min"       => $minrep,
		"max"       => $maxrep,
		"rightarg"  => $rightarg,
		"expected"  => "<${type}op: ".$leftarg->describe." ".$op->describe." ".$rightarg->describe.">",
	}, $class;
}

sub code($$$$)
{
	my ($self, $namespace, $rule) = @_;
	
	my ($leftarg, $op, $rightarg) =
		@{$self}{ qw{leftarg op rightarg} };

	my $code = '
		Parse::RecDescent::_trace(q{Trying operator: [' . $self->describe . ']},
				  Parse::RecDescent::_tracefirst($text),
				  q{' . $rule->{"name"} . '},
				  $tracelevel)
					if defined $::RD_TRACE;
		$expectation->is(' . ($rule->hasleftmost($self) ? 'q{}'
				# WAS : 'qq{'.$self->describe.'}' ) . ')->at($text);
				: 'q{'.$self->describe.'}' ) . ')->at($text);

		$_tok = undef;
		OPLOOP: while (1)
		{
		  $repcount = 0;
		  my  @item;
		  ';

	if ($self->{type} eq "leftop" )
	{
		$code .= '
		  # MATCH LEFTARG
		  ' . $leftarg->code(@_[1..2]) . '

		  $repcount++;

		  my $savetext = $text;
		  my $backtrack;

		  # MATCH (OP RIGHTARG)(s)
		  while ($repcount < ' . $self->{max} . ')
		  {
			$backtrack = 0;
			' . $op->code(@_[1..2]) . '
			' . ($op->isterminal() ? 'pop @item;' : '$backtrack=1;' ) . '
			' . (ref($op) eq 'Parse::RecDescent::Token'
				? 'if (defined $1) {push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; $backtrack=1;}'
				: "" ) . '
			' . $rightarg->code(@_[1..2]) . '
			$savetext = $text;
			$repcount++;
		  }
		  $text = $savetext;
		  pop @item if $backtrack;

		  ';
	}
	else
	{
		$code .= '
		  my $savetext = $text;
		  my $backtrack;
		  # MATCH (LEFTARG OP)(s)
		  while ($repcount < ' . $self->{max} . ')
		  {
			$backtrack = 0;
			' . $leftarg->code(@_[1..2]) . '
			$repcount++;
			$backtrack = 1;
			' . $op->code(@_[1..2]) . '
			$savetext = $text;
			' . ($op->isterminal() ? 'pop @item;' : "" ) . '
			' . (ref($op) eq 'Parse::RecDescent::Token' ? 'do { push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; } if defined $1;' : "" ) . '
		  }
		  $text = $savetext;
		  pop @item if $backtrack;

		  # MATCH RIGHTARG
		  ' . $rightarg->code(@_[1..2]) . '
		  $repcount++;
		  ';
	}

	$code .= 'unless (@item) { undef $_tok; last }' unless $self->{min}==0;

	$code .= '
		  $_tok = [ @item ];
		  last;
		} 

		unless ($repcount>='.$self->{min}.')
		{
			Parse::RecDescent::_trace(q{<<Didn\'t match operator: ['
						  . $self->describe
						  . ']>>},
						  Parse::RecDescent::_tracefirst($text),
						  q{' . $rule->{"name"} .'},
						  $tracelevel)
							if defined $::RD_TRACE;
			$expectation->failed();
			last;
		}
		Parse::RecDescent::_trace(q{>>Matched operator: ['
					  . $self->describe
					  . ']<< (return value: [}
					  . qq{@{$_tok||[]}} . q{]},
					  Parse::RecDescent::_tracefirst($text),
					  q{' . $rule->{"name"} .'},
					  $tracelevel)
						if defined $::RD_TRACE;

		push @item, $item{'.($self->{name}||$self->{hashname}).'}=$_tok||[];

';
	return $code;
}


package Parse::RecDescent::Expectation;

sub new ($)
{
	bless {
		"failed"	  => 0,
		"expected"	  => "",
		"unexpected"	  => "",
		"lastexpected"	  => "",
		"lastunexpected"  => "",
		"defexpected"	  => $_[1],
	      };
}

sub is ($$)
{
	$_[0]->{lastexpected} = $_[1]; return $_[0];
}

sub at ($$)
{
	$_[0]->{lastunexpected} = $_[1]; return $_[0];
}

sub failed ($)
{
	return unless $_[0]->{lastexpected};
	$_[0]->{expected}   = $_[0]->{lastexpected}   unless $_[0]->{failed};
	$_[0]->{unexpected} = $_[0]->{lastunexpected} unless $_[0]->{failed};
	$_[0]->{failed} = 1;
}

sub message ($)
{
	my ($self) = @_;
	$self->{expected} = $self->{defexpected} unless $self->{expected};
	$self->{expected} =~ s/_/ /g;
	if (!$self->{unexpected} || $self->{unexpected} =~ /\A\s*\Z/s)
	{
		return "Was expecting $self->{expected}";
	}
	else
	{
		$self->{unexpected} =~ /\s*(.*)/;
		return "Was expecting $self->{expected} but found \"$1\" instead";
	}
}

1;

package Parse::RecDescent;

use Carp;
use vars qw ( $AUTOLOAD $VERSION );

my $ERRORS = 0;

$VERSION = '1.94';

# BUILDING A PARSER

my $nextnamespace = "namespace000001";

sub _nextnamespace()
{
	return "Parse::RecDescent::" . $nextnamespace++;
}

sub new ($$$)
{
	my $class = ref($_[0]) || $_[0];
        local $Parse::RecDescent::compiling = $_[2];
        my $name_space_name = defined $_[3]
		? "Parse::RecDescent::".$_[3] 
		: _nextnamespace();
	my $self =
	{
		"rules"     => {},
		"namespace" => $name_space_name,
		"startcode" => '',
		"localvars" => '',
		"_AUTOACTION" => undef,
		"_AUTOTREE"   => undef,
	};
	if ($::RD_AUTOACTION)
	{
		my $sourcecode = $::RD_AUTOACTION;
		$sourcecode = "{ $sourcecode }"
			unless $sourcecode =~ /\A\s*\{.*\}\s*\Z/;
		$self->{_check}{itempos} =
			$sourcecode =~ /\@itempos\b|\$itempos\s*\[/;
		$self->{_AUTOACTION}
			= new Parse::RecDescent::Action($sourcecode,0,-1)
	}
	
	bless $self, $class;
	shift;
	return $self->Replace(@_)
}

sub Compile($$$$) {

	die "Compilation of Parse::RecDescent grammars not yet implemented\n";
}

sub DESTROY {}  # SO AUTOLOADER IGNORES IT

# BUILDING A GRAMMAR....

sub Replace ($$)
{
	splice(@_, 2, 0, 1);
	return _generate(@_);
}

sub Extend ($$)
{
	splice(@_, 2, 0, 0);
	return _generate(@_);
}

sub _no_rule ($$;$)
{
	_error("Ruleless $_[0] at start of grammar.",$_[1]);
	my $desc = $_[2] ? "\"$_[2]\"" : "";
	_hint("You need to define a rule for the $_[0] $desc
	       to be part of.");
}

my $NEGLOOKAHEAD	= '\G(\s*\.\.\.\!)';
my $POSLOOKAHEAD	= '\G(\s*\.\.\.)';
my $RULE		= '\G\s*(\w+)[ \t]*:';
my $PROD		= '\G\s*([|])';
my $TOKEN		= q{\G\s*/((\\\\/|[^/])*)/([cgimsox]*)};
my $MTOKEN		= q{\G\s*(m\s*[^\w\s])};
my $LITERAL		= q{\G\s*'((\\\\['\\\\]|[^'])*)'};
my $INTERPLIT		= q{\G\s*"((\\\\["\\\\]|[^"])*)"};
my $SUBRULE		= '\G\s*(\w+)';
my $MATCHRULE		= '\G(\s*<matchrule:)';
my $SIMPLEPAT		= '((\\s+/[^/\\\\]*(?:\\\\.[^/\\\\]*)*/)?)';
my $OPTIONAL		= '\G\((\?)'.$SIMPLEPAT.'\)';
my $ANY			= '\G\((s\?)'.$SIMPLEPAT.'\)';
my $MANY 		= '\G\((s|\.\.)'.$SIMPLEPAT.'\)';
my $EXACTLY		= '\G\(([1-9]\d*)'.$SIMPLEPAT.'\)';
my $BETWEEN		= '\G\((\d+)\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
my $ATLEAST		= '\G\((\d+)\.\.'.$SIMPLEPAT.'\)';
my $ATMOST		= '\G\(\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
my $BADREP		= '\G\((-?\d+)?\.\.(-?\d+)?'.$SIMPLEPAT.'\)';
my $ACTION		= '\G\s*\{';
my $IMPLICITSUBRULE	= '\G\s*\(';
my $COMMENT		= '\G\s*(#.*)';
my $COMMITMK		= '\G\s*<commit>';
my $UNCOMMITMK		= '\G\s*<uncommit>';
my $QUOTELIKEMK		= '\G\s*<perl_quotelike>';
my $CODEBLOCKMK		= '\G\s*<perl_codeblock(?:\s+([][()<>{}]+))?>';
my $VARIABLEMK		= '\G\s*<perl_variable>';
my $NOCHECKMK		= '\G\s*<nocheck>';
my $AUTOTREEMK		= '\G\s*<autotree>';
my $AUTOSTUBMK		= '\G\s*<autostub>';
my $AUTORULEMK		= '\G\s*<autorule:(.*?)>';
my $REJECTMK		= '\G\s*<reject>';
my $CONDREJECTMK	= '\G\s*<reject:';
my $SCOREMK		= '\G\s*<score:';
my $AUTOSCOREMK		= '\G\s*<autoscore:';
my $SKIPMK		= '\G\s*<skip:';
my $OPMK		= '\G\s*<(left|right)op(?:=(\'.*?\'))?:';
my $ENDDIRECTIVEMK	= '\G\s*>';
my $RESYNCMK		= '\G\s*<resync>';
my $RESYNCPATMK		= '\G\s*<resync:';
my $RULEVARPATMK	= '\G\s*<rulevar:';
my $DEFERPATMK		= '\G\s*<defer:';
my $TOKENPATMK		= '\G\s*<token:';
my $AUTOERRORMK		= '\G\s*<error(\??)>';
my $MSGERRORMK		= '\G\s*<error(\??):';
my $UNCOMMITPROD	= $PROD.'\s*<uncommit';
my $ERRORPROD		= $PROD.'\s*<error';
my $LONECOLON		= '\G\s*:';
my $OTHER		= '\G\s*([^\s]+)';

my $lines = 0;

sub _generate($$$;$$)
{
	my ($self, $grammar, $replace, $isimplicit, $isleftop) = (@_, 0);

	my $aftererror = 0;
	my $lookahead = 0;
	my $lookaheadspec = "";
	$lines = _linecount($grammar) unless $lines;
	$self->{_check}{itempos} = ($grammar =~ /\@itempos\b|\$itempos\s*\[/)
		unless $self->{_check}{itempos};
	for (qw(thisoffset thiscolumn prevline prevoffset prevcolumn))
	{
		$self->{_check}{$_} =
			($grammar =~ /\$$_/) || $self->{_check}{itempos}
				unless $self->{_check}{$_};
	}
	my $line;

	my $rule = undef;
	my $prod = undef;
	my $item = undef;
	my $lastgreedy = '';
	pos $grammar = 0;
	study $grammar;

	while (pos $grammar < length $grammar)
	{
		$line = $lines - _linecount($grammar) + 1;
		my $commitonly;
		my $code = "";
		my @components = ();
		if ($grammar =~ m/$COMMENT/gco)
		{
			_parse("a comment",0,$line);
			next;
		}
		elsif ($grammar =~ m/$NEGLOOKAHEAD/gco)
		{
			_parse("a negative lookahead",$aftererror,$line);
			$lookahead = $lookahead ? -$lookahead : -1;
			$lookaheadspec .= $1;
			next;	# SKIP LOOKAHEAD RESET AT END OF while LOOP
		}
		elsif ($grammar =~ m/$POSLOOKAHEAD/gco)
		{
			_parse("a positive lookahead",$aftererror,$line);
			$lookahead = $lookahead ? $lookahead : 1;
			$lookaheadspec .= $1;
			next;	# SKIP LOOKAHEAD RESET AT END OF while LOOP
		}
		elsif ($grammar =~ m/(?=$ACTION)/gco
			and do { ($code) = extract_codeblock($grammar); $code })
		{
			_parse("an action", $aftererror, $line, $code);
			$item = new Parse::RecDescent::Action($code,$lookahead,$line);
			$prod and $prod->additem($item)
			      or  $self->_addstartcode($code);
		}
		elsif ($grammar =~ m/(?=$IMPLICITSUBRULE)/gco
			and do { ($code) = extract_codeblock($grammar,'{([',undef,'(',1);
				$code })
		{
			$code =~ s/\A\s*\(|\)\Z//g;
			_parse("an implicit subrule", $aftererror, $line,
				"( $code )");
			my $implicit = $rule->nextimplicit;
			$self->_generate("$implicit : $code",$replace,1);
			my $pos = pos $grammar;
			substr($grammar,$pos,0,$implicit);
			pos $grammar = $pos;;
		}
		elsif ($grammar =~ m/$ENDDIRECTIVEMK/gco)
		{

		# EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)

			my ($minrep,$maxrep) = (1,$MAXREP);
			if ($grammar =~ m/\G[(]/gc)
			{
				pos($grammar)--;

				if ($grammar =~ m/$OPTIONAL/gco)
					{ ($minrep, $maxrep) = (0,1) }
				elsif ($grammar =~ m/$ANY/gco)
					{ $minrep = 0 }
				elsif ($grammar =~ m/$EXACTLY/gco)
					{ ($minrep, $maxrep) = ($1,$1) }
				elsif ($grammar =~ m/$BETWEEN/gco)
					{ ($minrep, $maxrep) = ($1,$2) }
				elsif ($grammar =~ m/$ATLEAST/gco)
					{ $minrep = $1 }
				elsif ($grammar =~ m/$ATMOST/gco)
					{ $maxrep = $1 }
				elsif ($grammar =~ m/$MANY/gco)
					{ }
				elsif ($grammar =~ m/$BADREP/gco)
				{
					_parse("an invalid repetition specifier", 0,$line);
					_error("Incorrect specification of a repeated directive",
					       $line);
					_hint("Repeated directives cannot have
					       a maximum repetition of zero, nor can they have
					       negative components in their ranges.");
				}
			}
			
			$prod && $prod->enddirective($line,$minrep,$maxrep);
		}
		elsif ($grammar =~ m/\G\s*<[^m]/gc)
		{
			pos($grammar)-=2;

			if ($grammar =~ m/$OPMK/gco)
			{
				# $DB::single=1;
				_parse("a $1-associative operator directive", $aftererror, $line, "<$1op:...>");
				$prod->adddirective($1, $line,$2||'');
			}
			elsif ($grammar =~ m/$UNCOMMITMK/gco)
			{
				_parse("an uncommit marker", $aftererror,$line);
				$item = new Parse::RecDescent::Directive('$commit=0;1',
								  $lookahead,$line,"<uncommit>");
				$prod and $prod->additem($item)
				      or  _no_rule("<uncommit>",$line);
			}
			elsif ($grammar =~ m/$QUOTELIKEMK/gco)
			{
				_parse("an perl quotelike marker", $aftererror,$line);
				$item = new Parse::RecDescent::Directive(
					'my ($match,@res);
					 ($match,$text,undef,@res) =
						  Text::Balanced::extract_quotelike($text,$skip);
					  $match ? \@res : undef;
					', $lookahead,$line,"<perl_quotelike>");
				$prod and $prod->additem($item)
				      or  _no_rule("<perl_quotelike>",$line);
			}
			elsif ($grammar =~ m/$CODEBLOCKMK/gco)
			{
				my $outer = $1||"{}";
				_parse("an perl codeblock marker", $aftererror,$line);
				$item = new Parse::RecDescent::Directive(
					'Text::Balanced::extract_codeblock($text,undef,$skip,\''.$outer.'\');
					', $lookahead,$line,"<perl_codeblock>");
				$prod and $prod->additem($item)
				      or  _no_rule("<perl_codeblock>",$line);
			}
			elsif ($grammar =~ m/$VARIABLEMK/gco)
			{
				_parse("an perl variable marker", $aftererror,$line);
				$item = new Parse::RecDescent::Directive(
					'Text::Balanced::extract_variable($text,$skip);
					', $lookahead,$line,"<perl_variable>");
				$prod and $prod->additem($item)
				      or  _no_rule("<perl_variable>",$line);
			}
			elsif ($grammar =~ m/$NOCHECKMK/gco)
			{
				_parse("a disable checking marker", $aftererror,$line);
				if ($rule)
				{
					_error("<nocheck> directive not at start of grammar", $line);
					_hint("The <nocheck> directive can only
					       be specified at the start of a
					       grammar (before the first rule 
					       is defined.");
				}
				else
				{
					local $::RD_CHECK = 1;
				}
			}
			elsif ($grammar =~ m/$AUTOSTUBMK/gco)
			{
				_parse("an autostub marker", $aftererror,$line);
				$::RD_AUTOSTUB = "";
			}
			elsif ($grammar =~ m/$AUTORULEMK/gco)
			{
				_parse("an autorule marker", $aftererror,$line);