recdescent.pm

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

				$::RD_AUTOSTUB = $1;
			}
			elsif ($grammar =~ m/$AUTOTREEMK/gco)
			{
				_parse("an autotree marker", $aftererror,$line);
				if ($rule)
				{
					_error("<autotree> directive not at start of grammar", $line);
					_hint("The <autotree> directive can only
					       be specified at the start of a
					       grammar (before the first rule 
					       is defined.");
				}
				else
				{
					undef $self->{_AUTOACTION};
					$self->{_AUTOTREE}{NODE}
						= new Parse::RecDescent::Action(q{{bless \%item, $item[0]}},0,-1);
					$self->{_AUTOTREE}{TERMINAL}
						= new Parse::RecDescent::Action(q{{bless {__VALUE__=>$item[1]}, $item[0]}},0,-1);
				}
			}

			elsif ($grammar =~ m/$REJECTMK/gco)
			{
				_parse("an reject marker", $aftererror,$line);
				$item = new Parse::RecDescent::UncondReject($lookahead,$line,"<reject>");
				$prod and $prod->additem($item)
				      or  _no_rule("<reject>",$line);
			}
			elsif ($grammar =~ m/(?=$CONDREJECTMK)/gco
				and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
					  $code })
			{
				_parse("a (conditional) reject marker", $aftererror,$line);
				$code =~ /\A\s*<reject:(.*)>\Z/s;
				$item = new Parse::RecDescent::Directive(
					      "($1) ? undef : 1", $lookahead,$line,"<reject:$code>");
				$prod and $prod->additem($item)
				      or  _no_rule("<reject:$code>",$line);
			}
			elsif ($grammar =~ m/(?=$SCOREMK)/gco
				and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
					  $code })
			{
				_parse("a score marker", $aftererror,$line);
				$code =~ /\A\s*<score:(.*)>\Z/s;
				$prod and $prod->addscore($1, $lookahead, $line)
				      or  _no_rule($code,$line);
			}
			elsif ($grammar =~ m/(?=$AUTOSCOREMK)/gco
				and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
					 $code;
				       } )
			{
				_parse("an autoscore specifier", $aftererror,$line,$code);
				$code =~ /\A\s*<autoscore:(.*)>\Z/s;

				$rule and $rule->addautoscore($1,$self)
				      or  _no_rule($code,$line);

				$item = new Parse::RecDescent::UncondReject($lookahead,$line,$code);
				$prod and $prod->additem($item)
				      or  _no_rule($code,$line);
			}
			elsif ($grammar =~ m/$RESYNCMK/gco)
			{
				_parse("a resync to newline marker", $aftererror,$line);
				$item = new Parse::RecDescent::Directive(
					      'if ($text =~ s/\A[^\n]*\n//) { $return = 0; $& } else { undef }',
					      $lookahead,$line,"<resync>");
				$prod and $prod->additem($item)
				      or  _no_rule("<resync>",$line);
			}
			elsif ($grammar =~ m/(?=$RESYNCPATMK)/gco
				and do { ($code) = extract_bracketed($grammar,'<');
					  $code })
			{
				_parse("a resync with pattern marker", $aftererror,$line);
				$code =~ /\A\s*<resync:(.*)>\Z/s;
				$item = new Parse::RecDescent::Directive(
					      'if ($text =~ s/\A'.$1.'//) { $return = 0; $& } else { undef }',
					      $lookahead,$line,$code);
				$prod and $prod->additem($item)
				      or  _no_rule($code,$line);
			}
			elsif ($grammar =~ m/(?=$SKIPMK)/gco
				and do { ($code) = extract_codeblock($grammar,'<');
					  $code })
			{
				_parse("a skip marker", $aftererror,$line);
				$code =~ /\A\s*<skip:(.*)>\Z/s;
				$item = new Parse::RecDescent::Directive(
					      'my $oldskip = $skip; $skip='.$1.'; $oldskip',
					      $lookahead,$line,$code);
				$prod and $prod->additem($item)
				      or  _no_rule($code,$line);
			}
			elsif ($grammar =~ m/(?=$RULEVARPATMK)/gco
				and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
					 $code;
				       } )
			{
				_parse("a rule variable specifier", $aftererror,$line,$code);
				$code =~ /\A\s*<rulevar:(.*)>\Z/s;

				$rule and $rule->addvar($1,$self)
				      or  _no_rule($code,$line);

				$item = new Parse::RecDescent::UncondReject($lookahead,$line,$code);
				$prod and $prod->additem($item)
				      or  _no_rule($code,$line);
			}
			elsif ($grammar =~ m/(?=$DEFERPATMK)/gco
				and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
					 $code;
				       } )
			{
				_parse("a deferred action specifier", $aftererror,$line,$code);
				$code =~ s/\A\s*<defer:(.*)>\Z/$1/s;
				if ($code =~ /\A\s*[^{]|[^}]\s*\Z/)
				{
					$code = "{ $code }"
				}

				$item = new Parse::RecDescent::Directive(
					      "push \@{\$thisparser->{deferred}}, sub $code;",
					      $lookahead,$line,"<defer:$code>");
				$prod and $prod->additem($item)
				      or  _no_rule("<defer:$code>",$line);

				$self->{deferrable} = 1;
			}
			elsif ($grammar =~ m/(?=$TOKENPATMK)/gco
				and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
					 $code;
				       } )
			{
				_parse("a token constructor", $aftererror,$line,$code);
				$code =~ s/\A\s*<token:(.*)>\Z/$1/s;

				my $types = eval 'no strict; local $SIG{__WARN__} = sub {0}; my @arr=('.$code.'); @arr' || (); 
				if (!$types)
				{
					_error("Incorrect token specification: \"$@\"", $line);
					_hint("The <token:...> directive requires a list
					       of one or more strings representing possible
					       types of the specified token. For example:
					       <token:NOUN,VERB>");
				}
				else
				{
					$item = new Parse::RecDescent::Directive(
						      'no strict;
						       $return = { text => $item[-1] };
						       @{$return->{type}}{'.$code.'} = (1..'.$types.');',
						      $lookahead,$line,"<token:$code>");
					$prod and $prod->additem($item)
					      or  _no_rule("<token:$code>",$line);
				}
			}
			elsif ($grammar =~ m/$COMMITMK/gco)
			{
				_parse("an commit marker", $aftererror,$line);
				$item = new Parse::RecDescent::Directive('$commit = 1',
								  $lookahead,$line,"<commit>");
				$prod and $prod->additem($item)
				      or  _no_rule("<commit>",$line);
			}
			elsif ($grammar =~ m/$AUTOERRORMK/gco)
			{
				$commitonly = $1;
				_parse("an error marker", $aftererror,$line);
				$item = new Parse::RecDescent::Error('',$lookahead,$1,$line);
				$prod and $prod->additem($item)
				      or  _no_rule("<error>",$line);
				$aftererror = !$commitonly;
			}
			elsif ($grammar =~ m/(?=$MSGERRORMK)/gco
				and do { $commitonly = $1;
					 ($code) = extract_bracketed($grammar,'<');
					$code })
			{
				_parse("an error marker", $aftererror,$line,$code);
				$code =~ /\A\s*<error\??:(.*)>\Z/s;
				$item = new Parse::RecDescent::Error($1,$lookahead,$commitonly,$line);
				$prod and $prod->additem($item)
				      or  _no_rule("$code",$line);
				$aftererror = !$commitonly;
			}
			elsif (do { $commitonly = $1;
					 ($code) = extract_bracketed($grammar,'<');
					$code })
			{
				if ($code =~ /^<[A-Z_]+>$/)
				{
					_error("Token items are not yet
					supported: \"$code\"",
					       $line);
					_hint("Items like $code that consist of angle
					brackets enclosing a sequence of
					uppercase characters will eventually
					be used to specify pre-lexed tokens
					in a grammar. That functionality is not
					yet implemented. Or did you misspell
					\"$code\"?");
				}
				else
				{
					_error("Untranslatable item encountered: \"$code\"",
					       $line);
					_hint("Did you misspell \"$code\"
						   or forget to comment it out?");
				}
			}
		}
		elsif ($grammar =~ m/$RULE/gco)
		{
			_parseunneg("a rule declaration", 0,
				    $lookahead,$line) or next;
			my $rulename = $1;
			if ($rulename =~ /Replace|Extend|Precompile|Save/ )
			{	
				_warn(2,"Rule \"$rulename\" hidden by method
				       Parse::RecDescent::$rulename",$line)
				and
				_hint("The rule named \"$rulename\" cannot be directly
                                       called through the Parse::RecDescent object
                                       for this grammar (although it may still
                                       be used as a subrule of other rules).
                                       It can't be directly called because
				       Parse::RecDescent::$rulename is already defined (it
				       is the standard method of all
				       parsers).");
			}
			$rule = new Parse::RecDescent::Rule($rulename,$self,$line,$replace);
			$prod->check_pending($line) if $prod;
			$prod = $rule->addprod( new Parse::RecDescent::Production );
			$aftererror = 0;
		}
		elsif ($grammar =~ m/$UNCOMMITPROD/gco)
		{
			pos($grammar)-=9;
			_parseunneg("a new (uncommitted) production",
				    0, $lookahead, $line) or next;

			$prod->check_pending($line) if $prod;
			$prod = new Parse::RecDescent::Production($line,1);
			$rule and $rule->addprod($prod)
			      or  _no_rule("<uncommit>",$line);
			$aftererror = 0;
		}
		elsif ($grammar =~ m/$ERRORPROD/gco)
		{
			pos($grammar)-=6;
			_parseunneg("a new (error) production", $aftererror,
				    $lookahead,$line) or next;
			$prod->check_pending($line) if $prod;
			$prod = new Parse::RecDescent::Production($line,0,1);
			$rule and $rule->addprod($prod)
			      or  _no_rule("<error>",$line);
			$aftererror = 0;
		}
		elsif ($grammar =~ m/$PROD/gco)
		{
			_parseunneg("a new production", 0,
				    $lookahead,$line) or next;
			$rule
			  and (!$prod || $prod->check_pending($line))
			  and $prod = $rule->addprod(new Parse::RecDescent::Production($line))
			or  _no_rule("production",$line);
			$aftererror = 0;
		}
		elsif ($grammar =~ m/$LITERAL/gco)
		{
			($code = $1) =~ s/\\\\/\\/g;
			_parse("a literal terminal", $aftererror,$line,$1);
			$item = new Parse::RecDescent::Literal($code,$lookahead,$line);
			$prod and $prod->additem($item)
			      or  _no_rule("literal terminal",$line,"'$1'");
		}
		elsif ($grammar =~ m/$INTERPLIT/gco)
		{
			_parse("an interpolated literal terminal", $aftererror,$line);
			$item = new Parse::RecDescent::InterpLit($1,$lookahead,$line);
			$prod and $prod->additem($item)
			      or  _no_rule("interpolated literal terminal",$line,"'$1'");
		}
		elsif ($grammar =~ m/$TOKEN/gco)
		{
			_parse("a /../ pattern terminal", $aftererror,$line);
			$item = new Parse::RecDescent::Token($1,'/',$3?$3:'',$lookahead,$line);
			$prod and $prod->additem($item)
			      or  _no_rule("pattern terminal",$line,"/$1/");
		}
		elsif ($grammar =~ m/(?=$MTOKEN)/gco
			and do { ($code, undef, @components)
					= extract_quotelike($grammar);
				 $code }
		      )

		{
			_parse("an m/../ pattern terminal", $aftererror,$line,$code);
			$item = new Parse::RecDescent::Token(@components[3,2,8],
							     $lookahead,$line);
			$prod and $prod->additem($item)
			      or  _no_rule("pattern terminal",$line,$code);
		}
		elsif ($grammar =~ m/(?=$MATCHRULE)/gco
				and do { ($code) = extract_bracketed($grammar,'<');
					 $code
				       }
		       or $grammar =~ m/$SUBRULE/gco
				and $code = $1)
		{
			my $name = $code;
			my $matchrule = 0;
			if (substr($name,0,1) eq '<')
			{
				$name =~ s/$MATCHRULE\s*//;
				$name =~ s/\s*>\Z//;
				$matchrule = 1;
			}

		# EXTRACT TRAILING ARG LIST (IF ANY)

			my ($argcode) = extract_codeblock($grammar, "[]",'') || '';

		# EXTRACT TRAILING REPETITION SPECIFIER (IF ANY)

			if ($grammar =~ m/\G[(]/gc)
			{
				pos($grammar)--;

				if ($grammar =~ m/$OPTIONAL/gco)
				{
					_parse("an zero-or-one subrule match", $aftererror,$line,"$code$argcode($1)");
					$item = new Parse::RecDescent::Repetition($name,$1,0,1,
									   $lookahead,$line,
									   $self,
									   $matchrule,
									   $argcode);
					$prod and $prod->additem($item)
					      or  _no_rule("repetition",$line,"$code$argcode($1)");

					!$matchrule and $rule and $rule->addcall($name);
				}
				elsif ($grammar =~ m/$ANY/gco)
				{
					_parse("a zero-or-more subrule match", $aftererror,$line,"$code$argcode($1)");
					if ($2)
					{
						my $pos = pos $grammar;
						substr($grammar,$pos,0,
						       "<leftop='$name(s?)': $name $2 $name>(s?) ");

						pos $grammar = $pos;
					}
					else
					{
						$item = new Parse::RecDescent::Repetition($name,$1,0,$MAXREP,
										   $lookahead,$line,
										   $self,
										   $matchrule,
										   $argcode);
						$prod and $prod->additem($item)
						      or  _no_rule("repetition",$line,"$code$argcode($1)");

						!$matchrule and $rule and $rule->addcall($name);

						_check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK;
					}
				}
				elsif ($grammar =~ m/$MANY/gco)
				{
					_parse("a one-or-more subrule match", $aftererror,$line,"$code$argcode($1)");
					if ($2)
					{
						# $DB::single=1;
						my $pos = pos $grammar;
						substr($grammar,$pos,0,
						       "<leftop='$name(s)': $name $2 $name> ");

						pos $grammar = $pos;
					}
					else
					{
						$item = new Parse::RecDescent::Repetition($name,$1,1,$MAXREP,
										   $lookahead,$line,
										   $self,
										   $matchrule,
										   $argcode);
										   
						$prod and $prod->additem($item)
						      or  _no_rule("repetition",$line,"$code$argcode($1)");

						!$matchrule and $rule and $rule->addcall($name);

						_check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK;
					}
				}
				elsif ($grammar =~ m/$EXACTLY/gco)
				{
					_parse("an exactly-$1-times subrule match", $aftererror,$line,"$code$argcode($1)");
					if ($2)
					{
						my $pos = pos $grammar;
						substr($grammar,$pos,0,
						       "<leftop='$name($1)': $name $2 $name>($1) ");

						pos $grammar = $pos;
					}
					else
					{
						$item = new Parse::RecDescent::Repetition($name,$1,$1,$1,
										   $lookahead,$line,
										   $self,
										   $matchrule,
										   $argcode);
						$prod and $prod->additem($item)
						      or  _no_rule("repetition",$line,"$code$argcode($1)");

						!$matchrule and $rule and $rule->addcall($name);
					}
				}
				elsif ($grammar =~ m/$BETWEEN/gco)
				{
					_parse("a $1-to-$2 subrule match", $aftererror,$line,"$code$argcode($1..$2)");
					if ($3)
					{
						my $pos = pos $grammar;
						substr($grammar,$pos,0,
						       "<leftop='$name($1..$2)': $name $3 $name>($1..$2) ");

						pos $grammar = $pos;
					}
					else
					{
						$item = new Parse::RecDescent::Repetition($name,"$1..$2",$1,$2,
										   $lookahead,$line,
										   $self,
										   $matchrule,
										   $argcode);
						$prod and $prod->additem($item)
						      or  _no_rule("repetition",$line,"$code$argcode($1..$2)");

						!$matchrule and $rule and $rule->addcall($name);
					}
				}
				elsif ($grammar =~ m/$ATLEAST/gco)
				{
					_parse("a $1-or-more subrule match", $aftererror,$line,"$code$argcode($1..)");
					if ($2)
					{
						my $pos = pos $grammar;
						substr($grammar,$pos,0,
						       "<leftop='$name($1..)': $name $2 $name>($1..) ");

						pos $grammar = $pos;
					}
					else
					{
						$item = new Parse::RecDescent::Repetition($name,"$1..",$1,$MAXREP,
										   $lookahead,$line,
										   $self,
										   $matchrule,
										   $argcode);
						$prod and $prod->additem($item)
						      or  _no_rule("repetition",$line,"$code$argcode($1..)");

						!$matchrule and $rule and $rule->addcall($name);
						_check_insatiable($name,"$1..",$grammar,$line) if $::RD_CHECK;
					}
				}
				elsif ($grammar =~ m/$ATMOST/gco)
				{
					_parse("a one-to-$1 subrule match", $aftererror,$line,"$code$argcode(..$1)");
					if ($2)
					{
						my $pos = pos $grammar;
						substr($grammar,$pos,0,
						       "<leftop='$name(..$1)': $name $2 $name>(..$1) ");

						pos $grammar = $pos;
					}
					else
					{
						$item = new Parse::RecDescent::Repetition($name,"..$1",1,$1,
										   $lookahead,$line,
										   $self,
										   $matchrule,
										   $argcode);
						$prod and $prod->additem($item)
						      or  _no_rule("repetition",$line,"$code$argcode(..$1)");

						!$matchrule and $rule and $rule->addcall($name);
					}
				}
				elsif ($grammar =~ m/$BADREP/gco)
				{
					_parse("an subrule match with invalid repetition specifier", 0,$line);
					_error("Incorrect specification of a repeated subrule",
					       $line);
					_hint("Repeated subrules lik