recdescent.pm

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

sub new ($$;$$)
{
	my ($self, $line, $uncommit, $error) = @_;
	my $class = ref($self) || $self;

	bless
	{
		"items"    => [],
		"uncommit" => $uncommit,
		"error"    => $error,
		"line"     => $line,
		strcount   => 0,
		patcount   => 0,
		dircount   => 0,
		actcount   => 0,
	}, $class;
}

sub expected ($)
{
	my $itemcount = scalar @{$_[0]->{"items"}};
	return ($itemcount) ? $_[0]->{"items"}[0]->describe(1) : '';
}

sub hasleftmost ($$)
{
	my ($self, $ref) = @_;
	return ${$self->{"items"}}[0] eq $ref  if scalar @{$self->{"items"}};
	return 0;
}

sub leftmostsubrule($)
{
	my $self = shift;

	if ( $#{$self->{"items"}} >= 0 )
	{
		my $subrule = $self->{"items"}[0]->issubrule();
		return $subrule if defined $subrule;
	}

	return ();
}

sub checkleftmost($)
{
	my @items = @{$_[0]->{"items"}};
	if (@items==1 && ref($items[0]) =~ /\AParse::RecDescent::Error/
	    && $items[0]->{commitonly} )
	{
		Parse::RecDescent::_warn(2,"Lone <error?> in production treated
					    as <error?> <reject>");
		Parse::RecDescent::_hint("A production consisting of a single
					  conditional <error?> directive would 
					  normally succeed (with the value zero) if the
					  rule is not 'commited' when it is
					  tried. Since you almost certainly wanted
					  '<error?> <reject>' Parse::RecDescent
					  supplied it for you.");
		push @{$_[0]->{items}},
			Parse::RecDescent::UncondReject->new(0,0,'<reject>');
	}
	elsif (@items==1 && ($items[0]->describe||"") =~ /<rulevar|<autoscore/)
	{
		# Do nothing
	}
	elsif (@items &&
		( ref($items[0]) =~ /\AParse::RecDescent::UncondReject/
		|| ($items[0]->describe||"") =~ /<autoscore/
		))
	{
		Parse::RecDescent::_warn(1,"Optimizing away production: [". $_[0]->describe ."]");
		my $what = $items[0]->describe =~ /<rulevar/
				? "a <rulevar> (which acts like an unconditional <reject> during parsing)"
		         : $items[0]->describe =~ /<autoscore/
				? "an <autoscore> (which acts like an unconditional <reject> during parsing)"
				: "an unconditional <reject>";
		my $caveat = $items[0]->describe =~ /<rulevar/
				? " after the specified variable was set up"
				: "";
		my $advice = @items > 1
				? "However, there were also other (useless) items after the leading "
				  . $items[0]->describe
				  . ", so you may have been expecting some other behaviour."
				: "You can safely ignore this message.";
		Parse::RecDescent::_hint("The production starts with $what. That means that the
					  production can never successfully match, so it was
					  optimized out of the final parser$caveat. $advice");
		return 0;
	}
	return 1;
}

sub changesskip($)
{
	my $item;
	foreach $item (@{$_[0]->{"items"}})
	{
		if (ref($item) =~ /Parse::RecDescent::(Action|Directive)/)
		{
			return 1 if $item->{code} =~ /\$skip/;
		}
	}
	return 0;
}

sub adddirective
{
	my ( $self, $whichop, $line, $name ) = @_;
	push @{$self->{op}},
		{ type=>$whichop, line=>$line, name=>$name,
		  offset=> scalar(@{$self->{items}}) };
}

sub addscore
{
	my ( $self, $code, $lookahead, $line ) = @_;
	$self->additem(Parse::RecDescent::Directive->new(
			      "local \$^W;
			       my \$thisscore = do { $code } + 0;
			       if (!defined(\$score) || \$thisscore>\$score)
					{ \$score=\$thisscore; \$score_return=\$item[-1]; }
			       undef;", $lookahead, $line,"<score: $code>") )
		unless $self->{items}[-1]->describe =~ /<score/;
	return 1;
}

sub check_pending
{
	my ( $self, $line ) = @_;
	if ($self->{op})
	{
	    while (my $next = pop @{$self->{op}})
	    {
		Parse::RecDescent::_error("Incomplete <$next->{type}op:...>.", $line);
		Parse::RecDescent::_hint(
			"The current production ended without completing the
			 <$next->{type}op:...> directive that started near line
			 $next->{line}. Did you forget the closing '>'?");
	    }
	}
	return 1;
}

sub enddirective
{
	my ( $self, $line, $minrep, $maxrep ) = @_;
	unless ($self->{op})
	{
		Parse::RecDescent::_error("Unmatched > found.", $line);
		Parse::RecDescent::_hint(
			"A '>' angle bracket was encountered, which typically
			 indicates the end of a directive. However no suitable
			 preceding directive was encountered. Typically this
			 indicates either a extra '>' in the grammar, or a
			 problem inside the previous directive.");
		return;
	}
	my $op = pop @{$self->{op}};
	my $span = @{$self->{items}} - $op->{offset};
	if ($op->{type} =~ /left|right/)
	{
	    if ($span != 3)
	    {
		Parse::RecDescent::_error(
			"Incorrect <$op->{type}op:...> specification:
			 expected 3 args, but found $span instead", $line);
		Parse::RecDescent::_hint(
			"The <$op->{type}op:...> directive requires a
			 sequence of exactly three elements. For example:
		         <$op->{type}op:leftarg /op/ rightarg>");
	    }
	    else
	    {
		push @{$self->{items}},
			Parse::RecDescent::Operator->new(
				$op->{type}, $minrep, $maxrep, splice(@{$self->{"items"}}, -3));
		$self->{items}[-1]->sethashname($self);
		$self->{items}[-1]{name} = $op->{name};
	    }
	}
}

sub prevwasreturn
{
	my ( $self, $line ) = @_;
	unless (@{$self->{items}})
	{
		Parse::RecDescent::_error(
			"Incorrect <return:...> specification:
			expected item missing", $line);
		Parse::RecDescent::_hint(
			"The <return:...> directive requires a
			sequence of at least one item. For example:
		        <return: list>");
		return;
	}
	push @{$self->{items}},
		Parse::RecDescent::Result->new();
}

sub additem
{
	my ( $self, $item ) = @_;
	$item->sethashname($self);
	push @{$self->{"items"}}, $item;
	return $item;
}


sub preitempos
{
	return q
	{
		push @itempos, {'offset' => {'from'=>$thisoffset, 'to'=>undef},
				'line'   => {'from'=>$thisline,   'to'=>undef},
				'column' => {'from'=>$thiscolumn, 'to'=>undef} };
	}
}

sub incitempos
{
	return q
	{
		$itempos[$#itempos]{'offset'}{'from'} += length($1);
		$itempos[$#itempos]{'line'}{'from'}   = $thisline;
		$itempos[$#itempos]{'column'}{'from'} = $thiscolumn;
	}
}

sub postitempos
{
	return q
	{
		$itempos[$#itempos]{'offset'}{'to'} = $prevoffset;
		$itempos[$#itempos]{'line'}{'to'}   = $prevline;
		$itempos[$#itempos]{'column'}{'to'} = $prevcolumn;
	}
}

sub code($$$$)
{
	my ($self,$namespace,$rule,$parser) = @_;
	my $code =
'
	while (!$_matched'
	. (defined $self->{"uncommit"} ? '' : ' && !$commit')
	. ')
	{
		' .
		($self->changesskip()
			? 'local $skip = defined($skip) ? $skip : $Parse::RecDescent::skip;'
			: '') .'
		Parse::RecDescent::_trace(q{Trying production: ['
					  . $self->describe . ']},
					  Parse::RecDescent::_tracefirst($_[1]),
					  q{' . $rule ->{name}. '},
					  $tracelevel)
						if defined $::RD_TRACE;
		my $thisprod = $thisrule->{"prods"}[' . $self->{"number"} . '];
		' . (defined $self->{"error"} ? '' : '$text = $_[1];' ) . '
		my $_savetext;
		@item = (q{' . $rule->{"name"} . '});
		%item = (__RULE__ => q{' . $rule->{"name"} . '});
		my $repcount = 0;

';
	$code .= 
'		my @itempos = ({});
'			if $parser->{_check}{itempos};

	my $item;
	my $i;

	for ($i = 0; $i < @{$self->{"items"}}; $i++)
	{
		$item = ${$self->{items}}[$i];

		$code .= preitempos() if $parser->{_check}{itempos};

		$code .= $item->code($namespace,$rule,$parser->{_check});

		$code .= postitempos() if $parser->{_check}{itempos};

	}

	if ($parser->{_AUTOACTION} && defined($item) && !$item->isa("Parse::RecDescent::Action"))
	{
		$code .= $parser->{_AUTOACTION}->code($namespace,$rule);
		Parse::RecDescent::_warn(1,"Autogenerating action in rule
					   \"$rule->{name}\":
					    $parser->{_AUTOACTION}{code}")
		and
		Parse::RecDescent::_hint("The \$::RD_AUTOACTION was defined,
					  so any production not ending in an
					  explicit action has the specified
		       			  \"auto-action\" automatically
					  appended.");
	}
	elsif ($parser->{_AUTOTREE} && defined($item) && !$item->isa("Parse::RecDescent::Action"))
	{
		if ($i==1 && $item->isterminal)
		{
			$code .= $parser->{_AUTOTREE}{TERMINAL}->code($namespace,$rule);
		}
		else
		{
			$code .= $parser->{_AUTOTREE}{NODE}->code($namespace,$rule);
		}
		Parse::RecDescent::_warn(1,"Autogenerating tree-building action in rule
					   \"$rule->{name}\"")
		and
		Parse::RecDescent::_hint("The directive <autotree> was specified,
                                          so any production not ending
                                          in an explicit action has
                                          some parse-tree building code
                                          automatically appended.");
	}

	$code .= 
'

		Parse::RecDescent::_trace(q{>>Matched production: ['
					  . $self->describe . ']<<},
					  Parse::RecDescent::_tracefirst($text),
					  q{' . $rule->{name} . '},
					  $tracelevel)
						if defined $::RD_TRACE;
		$_matched = 1;
		last;
	}

';
	return $code;
}

1;

package Parse::RecDescent::Action;

sub describe { undef }

sub sethashname { $_[0]->{hashname} = '__ACTION' . ++$_[1]->{actcount} .'__'; }

sub new
{
	my $class = ref($_[0]) || $_[0];
	bless 
	{
		"code"      => $_[1],
		"lookahead" => $_[2],
		"line"      => $_[3],
	}, $class;
}

sub issubrule { undef }
sub isterminal { 0 }

sub code($$$$)
{
	my ($self, $namespace, $rule) = @_;
	
'
		Parse::RecDescent::_trace(q{Trying action},
					  Parse::RecDescent::_tracefirst($text),
					  q{' . $rule->{name} . '},
					  $tracelevel)
						if defined $::RD_TRACE;
		' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'

		$_tok = ($_noactions) ? 0 : do ' . $self->{"code"} . ';
		' . ($self->{"lookahead"}<0?'if':'unless') . ' (defined $_tok)
		{
			Parse::RecDescent::_trace(q{<<Didn\'t match action>> (return value: [undef])})
					if defined $::RD_TRACE;
			last;
		}
		Parse::RecDescent::_trace(q{>>Matched action<< (return value: [}
					  . $_tok . q{])},
					  Parse::RecDescent::_tracefirst($text))
						if defined $::RD_TRACE;
		push @item, $_tok;
		' . ($self->{line}>=0 ? '$item{'. $self->{hashname} .'}=$_tok;' : '' ) .'
		' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
'
}


1;

package Parse::RecDescent::Directive;

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

sub issubrule { undef }
sub isterminal { 0 }
sub describe { $_[1] ? '' : $_[0]->{name} } 

sub new ($$$$$)
{
	my $class = ref($_[0]) || $_[0];
	bless 
	{
		"code"      => $_[1],
		"lookahead" => $_[2],
		"line"      => $_[3],
		"name"      => $_[4],
	}, $class;
}

sub code($$$$)
{
	my ($self, $namespace, $rule) = @_;
	
'
		' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'

		Parse::RecDescent::_trace(q{Trying directive: ['
					. $self->describe . ']},
					Parse::RecDescent::_tracefirst($text),
					  q{' . $rule->{name} . '},
					  $tracelevel)
						if defined $::RD_TRACE; ' .'
		$_tok = do { ' . $self->{"code"} . ' };
		if (defined($_tok))
		{
			Parse::RecDescent::_trace(q{>>Matched directive<< (return value: [}
						. $_tok . q{])},
						Parse::RecDescent::_tracefirst($text))
							if defined $::RD_TRACE;
		}
		else
		{
			Parse::RecDescent::_trace(q{<<Didn\'t match directive>>},
						Parse::RecDescent::_tracefirst($text))
							if defined $::RD_TRACE;
		}
		' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
		last '
		. ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
		push @item, $item{'.$self->{hashname}.'}=$_tok;
		' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .'
'
}

1;

package Parse::RecDescent::UncondReject;

sub issubrule { undef }
sub isterminal { 0 }
sub describe { $_[1] ? '' : $_[0]->{name} }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} .  '__'; }

sub new ($$$;$)
{
	my $class = ref($_[0]) || $_[0];
	bless 
	{
		"lookahead" => $_[1],
		"line"      => $_[2],
		"name"      => $_[3],
	}, $class;
}

# MARK, YOU MAY WANT TO OPTIMIZE THIS.


sub code($$$$)
{
	my ($self, $namespace, $rule) = @_;
	
'
		Parse::RecDescent::_trace(q{>>Rejecting production<< (found '
					 . $self->describe . ')},
					 Parse::RecDescent::_tracefirst($text),
					  q{' . $rule->{name} . '},
					  $tracelevel)
						if defined $::RD_TRACE;
		undef $return;
		' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'

		$_tok = undef;
		' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .'
		last '
		. ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok;
'
}

1;

package Parse::RecDescent::Error;

sub issubrule { undef }
sub isterminal { 0 }
sub describe { $_[1] ? '' : $_[0]->{commitonly} ? '<error?:...>' : '<error...>' }
sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} .  '__'; }

sub new ($$$$$)
{
	my $class = ref($_[0]) || $_[0];
	bless 
	{
		"msg"        => $_[1],
		"lookahead"  => $_[2],
		"commitonly" => $_[3],