recdescent.pm

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

# GENERATE RECURSIVE DESCENT PARSER OBJECTS FROM A GRAMMARC
# SEE RecDescent.pod FOR FULL DETAILS

use 5.005;
use strict;

package Parse::RecDescent;

use Text::Balanced qw ( extract_codeblock extract_bracketed extract_quotelike extract_delimited );

use vars qw ( $skip );

   *defskip  = \ '\s*';	# DEFAULT SEPARATOR IS OPTIONAL WHITESPACE
   $skip  = '\s*';		# UNIVERSAL SEPARATOR IS OPTIONAL WHITESPACE
my $MAXREP  = 100_000_000;	# REPETITIONS MATCH AT MOST 100,000,000 TIMES


sub import	# IMPLEMENT PRECOMPILER BEHAVIOUR UNDER:
		#    perl -MParse::RecDescent - <grammarfile> <classname>
{
	local *_die = sub { print @_, "\n"; exit };

	my ($package, $file, $line) = caller;
	if (substr($file,0,1) eq '-' && $line == 0)
	{
		_die("Usage: perl -MLocalTest - <grammarfile> <classname>")
			unless @ARGV == 2;

		my ($sourcefile, $class) = @ARGV;

		local *IN;
		open IN, $sourcefile
			or _die("Can't open grammar file '$sourcefile'");

		my $grammar = join '', <IN>;

		Parse::RecDescent->Precompile($grammar, $class, $sourcefile);
		exit;
	}
}
		
sub Save
{
	my ($self, $class) = @_;
	$self->{saving} = 1;
	$self->Precompile(undef,$class);
	$self->{saving} = 0;
}

sub Precompile
{
		my ($self, $grammar, $class, $sourcefile) = @_;

		$class =~ /^(\w+::)*\w+$/ or croak("Bad class name: $class");

		my $modulefile = $class;
		$modulefile =~ s/.*:://;
		$modulefile .= ".pm";

		open OUT, ">$modulefile"
			or croak("Can't write to new module file '$modulefile'");

		print STDERR "precompiling grammar from file '$sourcefile'\n",
			     "to class $class in module file '$modulefile'\n"
					if $grammar && $sourcefile;

		# local $::RD_HINT = 1;
		$self = Parse::RecDescent->new($grammar,1,$class)
			|| croak("Can't compile bad grammar")
				if $grammar;

		foreach ( keys %{$self->{rules}} )
			{ $self->{rules}{$_}{changed} = 1 }

		print OUT "package $class;\nuse Parse::RecDescent;\n\n";

		print OUT "{ my \$ERRORS;\n\n";

		print OUT $self->_code();

		print OUT "}\npackage $class; sub new { ";
		print OUT "my ";

		require Data::Dumper;
		print OUT Data::Dumper->Dump([$self], [qw(self)]);

		print OUT "}";

		close OUT
			or croak("Can't write to new module file '$modulefile'");
}


package Parse::RecDescent::LineCounter;


sub TIESCALAR	# ($classname, \$text, $thisparser, $prevflag)
{
	bless {
		text    => $_[1],
		parser  => $_[2],
		prev	=> $_[3]?1:0,
	      }, $_[0];
}

my %counter_cache;

sub FETCH
{
        my $parser = $_[0]->{parser};
        my $from = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}
;

    unless (exists $counter_cache{$from}) {
        $parser->{lastlinenum} = $parser->{offsetlinenum}
		   - Parse::RecDescent::_linecount(substr($parser->{fulltext},$from))
                   + 1;
        $counter_cache{$from} = $parser->{lastlinenum};
    }
    return $counter_cache{$from};
}

sub STORE
{
	my $parser = $_[0]->{parser};
	$parser->{offsetlinenum} -= $parser->{lastlinenum} - $_[1];
	return undef;
}

sub resync       # ($linecounter)
{
        my $self = tied($_[0]);
        die "Tried to alter something other than a LineCounter\n"
                unless $self =~ /Parse::RecDescent::LineCounter/;
	
	my $parser = $self->{parser};
	my $apparently = $parser->{offsetlinenum}
			 - Parse::RecDescent::_linecount(${$self->{text}})
			 + 1;

	$parser->{offsetlinenum} += $parser->{lastlinenum} - $apparently;
	return 1;
}

package Parse::RecDescent::ColCounter;

sub TIESCALAR	# ($classname, \$text, $thisparser, $prevflag)
{
	bless {
		text    => $_[1],
		parser  => $_[2],
		prev    => $_[3]?1:0,
	      }, $_[0];
}

sub FETCH    
{
	my $parser = $_[0]->{parser};
	my $missing = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}+1;
	substr($parser->{fulltext},0,$missing) =~ m/^(.*)\Z/m;
	return length($1);
}

sub STORE
{
	die "Can't set column number via \$thiscolumn\n";
}


package Parse::RecDescent::OffsetCounter;

sub TIESCALAR	# ($classname, \$text, $thisparser, $prev)
{
	bless {
		text    => $_[1],
		parser  => $_[2],
		prev	=> $_[3]?-1:0,
	      }, $_[0];
}

sub FETCH    
{
	my $parser = $_[0]->{parser};
	return $parser->{fulltextlen}-length(${$_[0]->{text}})+$_[0]->{prev};
}

sub STORE
{
	die "Can't set current offset via \$thisoffset or \$prevoffset\n";
}



package Parse::RecDescent::Rule;

sub new ($$$$$)
{
	my $class = ref($_[0]) || $_[0];
	my $name  = $_[1];
	my $owner = $_[2];
	my $line  = $_[3];
	my $replace = $_[4];

	if (defined $owner->{"rules"}{$name})
	{
		my $self = $owner->{"rules"}{$name};
		if ($replace && !$self->{"changed"})
		{
			$self->reset;
		}
		return $self;
	}
	else
	{
		return $owner->{"rules"}{$name} =
			bless
			{
				"name"     => $name,
				"prods"    => [],
				"calls"    => [],
				"changed"  => 0,
				"line"     => $line,
				"impcount" => 0,
				"opcount"  => 0,
				"vars"	   => "",
			}, $class;
	}
}

sub reset($)
{
	@{$_[0]->{"prods"}} = ();
	@{$_[0]->{"calls"}} = ();
	$_[0]->{"changed"}  = 0;
	$_[0]->{"impcount"}  = 0;
	$_[0]->{"opcount"}  = 0;
	$_[0]->{"vars"}  = "";
}

sub DESTROY {}

sub hasleftmost($$)
{
	my ($self, $ref) = @_;

	my $prod;
	foreach $prod ( @{$self->{"prods"}} )
	{
		return 1 if $prod->hasleftmost($ref);
	}

	return 0;
}

sub leftmostsubrules($)
{
	my $self = shift;
	my @subrules = ();

	my $prod;
	foreach $prod ( @{$self->{"prods"}} )
	{
		push @subrules, $prod->leftmostsubrule();
	}

	return @subrules;
}

sub expected($)
{
	my $self = shift;
	my @expected = ();

	my $prod;
	foreach $prod ( @{$self->{"prods"}} )
	{
		my $next = $prod->expected();
		unless (! $next or _contains($next,@expected) )
		{
			push @expected, $next;
		}
	}

	return join ', or ', @expected;
}

sub _contains($@)
{
	my $target = shift;
	my $item;
	foreach $item ( @_ ) { return 1 if $target eq $item; }
	return 0;
}

sub addcall($$)
{
	my ( $self, $subrule ) = @_;
	unless ( _contains($subrule, @{$self->{"calls"}}) )
	{
		push @{$self->{"calls"}}, $subrule;
	}
}

sub addprod($$)
{
	my ( $self, $prod ) = @_;
	push @{$self->{"prods"}}, $prod;
	$self->{"changed"} = 1;
	$self->{"impcount"} = 0;
	$self->{"opcount"} = 0;
	$prod->{"number"} = $#{$self->{"prods"}};
	return $prod;
}

sub addvar
{
	my ( $self, $var, $parser ) = @_;
	if ($var =~ /\A\s*local\s+([%@\$]\w+)/)
	{
		$parser->{localvars} .= " $1";
		$self->{"vars"} .= "$var;\n" }
	else 
		{ $self->{"vars"} .= "my $var;\n" }
	$self->{"changed"} = 1;
	return 1;
}

sub addautoscore
{
	my ( $self, $code ) = @_;
	$self->{"autoscore"} = $code;
	$self->{"changed"} = 1;
	return 1;
}

sub nextoperator($)
{
	my $self = shift;
	my $prodcount = scalar @{$self->{"prods"}};
	my $opcount = ++$self->{"opcount"};
	return "_operator_${opcount}_of_production_${prodcount}_of_rule_$self->{name}";
}

sub nextimplicit($)
{
	my $self = shift;
	my $prodcount = scalar @{$self->{"prods"}};
	my $impcount = ++$self->{"impcount"};
	return "_alternation_${impcount}_of_production_${prodcount}_of_rule_$self->{name}";
}


sub code
{
	my ($self, $namespace, $parser) = @_;

eval 'undef &' . $namespace . '::' . $self->{"name"} unless $parser->{saving};

	my $code =
'
# ARGS ARE: ($parser, $text; $repeating, $_noactions, \@args)
sub ' . $namespace . '::' . $self->{"name"} .  '
{
	my $thisparser = $_[0];
	use vars q{$tracelevel};
	local $tracelevel = ($tracelevel||0)+1;
	$ERRORS = 0;
	my $thisrule = $thisparser->{"rules"}{"' . $self->{"name"} . '"};
	
	Parse::RecDescent::_trace(q{Trying rule: [' . $self->{"name"} . ']},
				  Parse::RecDescent::_tracefirst($_[1]),
				  q{' . $self->{"name"} . '},
				  $tracelevel)
					if defined $::RD_TRACE;

	' . ($parser->{deferrable}
		? 'my $def_at = @{$thisparser->{deferred}};'
		: '') .
	'
	my $err_at = @{$thisparser->{errors}};

	my $score;
	my $score_return;
	my $_tok;
	my $return = undef;
	my $_matched=0;
	my $commit=0;
	my @item = ();
	my %item = ();
	my $repeating =  defined($_[2]) && $_[2];
	my $_noactions = defined($_[3]) && $_[3];
 	my @arg =        defined $_[4] ? @{ &{$_[4]} } : ();
	my %arg =        ($#arg & 01) ? @arg : (@arg, undef);
	my $text;
	my $lastsep="";
	my $expectation = new Parse::RecDescent::Expectation($thisrule->expected());
	$expectation->at($_[1]);
	'. ($parser->{_check}{thisoffset}?'
	my $thisoffset;
	tie $thisoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser;
	':'') . ($parser->{_check}{prevoffset}?'
	my $prevoffset;
	tie $prevoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser, 1;
	':'') . ($parser->{_check}{thiscolumn}?'
	my $thiscolumn;
	tie $thiscolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser;
	':'') . ($parser->{_check}{prevcolumn}?'
	my $prevcolumn;
	tie $prevcolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser, 1;
	':'') . ($parser->{_check}{prevline}?'
	my $prevline;
	tie $prevline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser, 1;
	':'') . '
	my $thisline;
	tie $thisline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser;

	'. $self->{vars} .'
';

	my $prod;
	foreach $prod ( @{$self->{"prods"}} )
	{
		$prod->addscore($self->{autoscore},0,0) if $self->{autoscore};
		next unless $prod->checkleftmost();
		$code .= $prod->code($namespace,$self,$parser);

		$code .= $parser->{deferrable}
				? '		splice
				@{$thisparser->{deferred}}, $def_at unless $_matched;
				  '
				: '';
	}

	$code .=
'
        unless ( $_matched || defined($return) || defined($score) )
	{
		' .($parser->{deferrable}
			? '		splice @{$thisparser->{deferred}}, $def_at;
			  '
			: '') . '

		$_[1] = $text;	# NOT SURE THIS IS NEEDED
		Parse::RecDescent::_trace(q{<<Didn\'t match rule>>},
					 Parse::RecDescent::_tracefirst($_[1]),
					 q{' . $self->{"name"} .'},
					 $tracelevel)
					if defined $::RD_TRACE;
		return undef;
	}
	if (!defined($return) && defined($score))
	{
		Parse::RecDescent::_trace(q{>>Accepted scored production<<}, "",
					  q{' . $self->{"name"} .'},
					  $tracelevel)
						if defined $::RD_TRACE;
		$return = $score_return;
	}
	splice @{$thisparser->{errors}}, $err_at;
	$return = $item[$#item] unless defined $return;
	if (defined $::RD_TRACE)
	{
		Parse::RecDescent::_trace(q{>>Matched rule<< (return value: [} .
					  $return . q{])}, "",
					  q{' . $self->{"name"} .'},
					  $tracelevel);
		Parse::RecDescent::_trace(q{(consumed: [} .
					  Parse::RecDescent::_tracemax(substr($_[1],0,-length($text))) . q{])}, 
					  Parse::RecDescent::_tracefirst($text),
					  , q{' . $self->{"name"} .'},
					  $tracelevel)
	}
	$_[1] = $text;
	return $return;
}
';

	return $code;
}

my @left;
sub isleftrec($$)
{
	my ($self, $rules) = @_;
	my $root = $self->{"name"};
	@left = $self->leftmostsubrules();
	my $next;
	foreach $next ( @left )
	{
		next unless defined $rules->{$next}; # SKIP NON-EXISTENT RULES
		return 1 if $next eq $root;
		my $child;
		foreach $child ( $rules->{$next}->leftmostsubrules() )
		{
		    push(@left, $child)
			if ! _contains($child, @left) ;
		}
	}
	return 0;
}

package Parse::RecDescent::Production;

sub describe ($;$)
{
	return join ' ', map { $_->describe($_[1]) or () } @{$_[0]->{items}};
}