balanced.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

		_failmsg "Did not find prefix: /$pre/", pos $$textref;
		return;
	}
	my $varpos = pos($$textref);
        unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci)
	{
	    unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc)
	    {
		_failmsg "Did not find leading dereferencer", pos $$textref;
		pos $$textref = $startpos;
		return;
	    }
	    my $deref = $1;

	    unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
	    	or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0)
		or $deref eq '$#' or $deref eq '$$' )
	    {
		_failmsg "Bad identifier after dereferencer", pos $$textref;
		pos $$textref = $startpos;
		return;
	    }
	}

	while (1)
	{
		next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc;
		next if _match_codeblock($textref,
					 qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/,
					 qr/[({[]/, qr/[)}\]]/,
					 qr/[({[]/, qr/[)}\]]/, 0);
		next if _match_codeblock($textref,
					 qr/\s*/, qr/[{[]/, qr/[}\]]/,
					 qr/[{[]/, qr/[}\]]/, 0);
		next if _match_variable($textref,'\s*->\s*');
		next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc;
		last;
	}
	
	my $endpos = pos($$textref);
	return ($startpos, $varpos-$startpos,
		$varpos,   $endpos-$varpos,
		$endpos,   length($$textref)-$endpos
		);
}

sub extract_codeblock (;$$$$$)
{
	my $textref = defined $_[0] ? \$_[0] : \$_;
	my $wantarray = wantarray;
	my $ldel_inner = defined $_[1] ? $_[1] : '{';
	my $pre        = defined $_[2] ? $_[2] : '\s*';
	my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner;
	my $rd         = $_[4];
	my $rdel_inner = $ldel_inner;
	my $rdel_outer = $ldel_outer;
	my $posbug = pos;
	for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds }
	for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds }
	for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer)
	{
		$_ = '('.join('|',map { quotemeta $_ } split('',$_)).')'
	}
	pos = $posbug;

	my @match = _match_codeblock($textref, $pre,
				     $ldel_outer, $rdel_outer,
				     $ldel_inner, $rdel_inner,
				     $rd);
	return _fail($wantarray, $textref) unless @match;
	return _succeed($wantarray, $textref,
			@match[2..3,4..5,0..1]	# MATCH, REMAINDER, PREFIX
		       );

}

sub _match_codeblock($$$$$$$)
{
	my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_;
	my $startpos = pos($$textref) = pos($$textref) || 0;
	unless ($$textref =~ m/\G($pre)/gc)
	{
		_failmsg qq{Did not match prefix /$pre/ at"} .
			    substr($$textref,pos($$textref),20) .
			    q{..."},
		         pos $$textref;
		return; 
	}
	my $codepos = pos($$textref);
	unless ($$textref =~ m/\G($ldel_outer)/gc)	# OUTERMOST DELIMITER
	{
		_failmsg qq{Did not find expected opening bracket at "} .
			     substr($$textref,pos($$textref),20) .
			     q{..."},
		         pos $$textref;
		pos $$textref = $startpos;
		return;
	}
	my $closing = $1;
	   $closing =~ tr/([<{/)]>}/;
	my $matched;
	my $patvalid = 1;
	while (pos($$textref) < length($$textref))
	{
		$matched = '';
		if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc)
		{
			$patvalid = 0;
			next;
		}

		if ($$textref =~ m/\G\s*#.*/gc)
		{
			next;
		}

		if ($$textref =~ m/\G\s*($rdel_outer)/gc)
		{
			unless ($matched = ($closing && $1 eq $closing) )
			{
				next if $1 eq '>';	# MIGHT BE A "LESS THAN"
				_failmsg q{Mismatched closing bracket at "} .
					     substr($$textref,pos($$textref),20) .
					     qq{...". Expected '$closing'},
					 pos $$textref;
			}
			last;
		}

		if (_match_variable($textref,'\s*') ||
		    _match_quotelike($textref,'\s*',$patvalid,$patvalid) )
		{
			$patvalid = 0;
			next;
		}


		# NEED TO COVER MANY MORE CASES HERE!!!
		if ($$textref =~ m#\G\s*(?!$ldel_inner)
					( [-+*x/%^&|.]=?
					| [!=]~
					| =(?!>)
					| (\*\*|&&|\|\||<<|>>)=?
					| split|grep|map|return
					| [([]
					)#gcx)
		{
			$patvalid = 1;
			next;
		}

		if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) )
		{
			$patvalid = 1;
			next;
		}

		if ($$textref =~ m/\G\s*$ldel_outer/gc)
		{
			_failmsg q{Improperly nested codeblock at "} .
				     substr($$textref,pos($$textref),20) .
				     q{..."},
				 pos $$textref;
			last;
		}

		$patvalid = 0;
		$$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc;
	}
	continue { $@ = undef }

	unless ($matched)
	{
		_failmsg 'No match found for opening bracket', pos $$textref
			unless $@;
		return;
	}

	my $endpos = pos($$textref);
	return ( $startpos, $codepos-$startpos,
		 $codepos, $endpos-$codepos,
		 $endpos,  length($$textref)-$endpos,
	       );
}


my %mods   = (
		'none'	=> '[cgimsox]*',
		'm'	=> '[cgimsox]*',
		's'	=> '[cegimsox]*',
		'tr'	=> '[cds]*',
		'y'	=> '[cds]*',
		'qq'	=> '',
		'qx'	=> '',
		'qw'	=> '',
		'qr'	=> '[imsx]*',
		'q'	=> '',
	     );

sub extract_quotelike (;$$)
{
	my $textref = $_[0] ? \$_[0] : \$_;
	my $wantarray = wantarray;
	my $pre  = defined $_[1] ? $_[1] : '\s*';

	my @match = _match_quotelike($textref,$pre,1,0);
	return _fail($wantarray, $textref) unless @match;
	return _succeed($wantarray, $textref,
			$match[2], $match[18]-$match[2],	# MATCH
			@match[18,19],				# REMAINDER
			@match[0,1],				# PREFIX
			@match[2..17],				# THE BITS
			@match[20,21],				# ANY FILLET?
		       );
};

sub _match_quotelike($$$$)	# ($textref, $prepat, $allow_raw_match)
{
	my ($textref, $pre, $rawmatch, $qmark) = @_;

	my ($textlen,$startpos,
	    $oppos,
	    $preld1pos,$ld1pos,$str1pos,$rd1pos,
	    $preld2pos,$ld2pos,$str2pos,$rd2pos,
	    $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 );

	unless ($$textref =~ m/\G($pre)/gc)
	{
		_failmsg qq{Did not find prefix /$pre/ at "} .
			     substr($$textref, pos($$textref), 20) .
			     q{..."},
		         pos $$textref;
		return; 
	}
	$oppos = pos($$textref);

	my $initial = substr($$textref,$oppos,1);

	if ($initial && $initial =~ m|^[\"\'\`]|
		     || $rawmatch && $initial =~ m|^/|
		     || $qmark && $initial =~ m|^\?|)
	{
		unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx)
		{
			_failmsg qq{Did not find closing delimiter to match '$initial' at "} .
				     substr($$textref, $oppos, 20) .
				     q{..."},
				 pos $$textref;
			pos $$textref = $startpos;
			return;
		}
		$modpos= pos($$textref);
		$rd1pos = $modpos-1;

		if ($initial eq '/' || $initial eq '?') 
		{
			$$textref =~ m/\G$mods{none}/gc
		}

		my $endpos = pos($$textref);
		return (
			$startpos,	$oppos-$startpos,	# PREFIX
			$oppos,		0,			# NO OPERATOR
			$oppos,		1,			# LEFT DEL
			$oppos+1,	$rd1pos-$oppos-1,	# STR/PAT
			$rd1pos,	1,			# RIGHT DEL
			$modpos,	0,			# NO 2ND LDEL
			$modpos,	0,			# NO 2ND STR
			$modpos,	0,			# NO 2ND RDEL
			$modpos,	$endpos-$modpos,	# MODIFIERS
			$endpos, 	$textlen-$endpos,	# REMAINDER
		       );
	}

	unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
	{
		_failmsg q{No quotelike operator found after prefix at "} .
			     substr($$textref, pos($$textref), 20) .
			     q{..."},
		         pos $$textref;
		pos $$textref = $startpos;
		return;
	}

	my $op = $1;
	$preld1pos = pos($$textref);
	if ($op eq '<<') {
		$ld1pos = pos($$textref);
		my $label;
		if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) {
			$label = $1;
		}
		elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) '
				     | \G " ([^"\\]* (?:\\.[^"\\]*)*) "
				     | \G ` ([^`\\]* (?:\\.[^`\\]*)*) `
				     }gcsx) {
			$label = $+;
		}
		else {
			$label = "";
		}
		my $extrapos = pos($$textref);
		$$textref =~ m{.*\n}gc;
		$str1pos = pos($$textref)--;
		unless ($$textref =~ m{.*?\n(?=\Q$label\E\n)}gc) {
			_failmsg qq{Missing here doc terminator ('$label') after "} .
				     substr($$textref, $startpos, 20) .
				     q{..."},
				 pos $$textref;
			pos $$textref = $startpos;
			return;
		}
		$rd1pos = pos($$textref);
        $$textref =~ m{\Q$label\E\n}gc;
		$ld2pos = pos($$textref);
		return (
			$startpos,	$oppos-$startpos,	# PREFIX
			$oppos,		length($op),		# OPERATOR
			$ld1pos,	$extrapos-$ld1pos,	# LEFT DEL
			$str1pos,	$rd1pos-$str1pos,	# STR/PAT
			$rd1pos,	$ld2pos-$rd1pos,	# RIGHT DEL
			$ld2pos,	0,			# NO 2ND LDEL
			$ld2pos,	0,                	# NO 2ND STR
			$ld2pos,	0,	                # NO 2ND RDEL
			$ld2pos,	0,                      # NO MODIFIERS
			$ld2pos,	$textlen-$ld2pos,	# REMAINDER
			$extrapos,      $str1pos-$extrapos,	# FILLETED BIT
		       );
	}

	$$textref =~ m/\G\s*/gc;
	$ld1pos = pos($$textref);
	$str1pos = $ld1pos+1;

	unless ($$textref =~ m/\G(\S)/gc)	# SHOULD USE LOOKAHEAD
	{
		_failmsg "No block delimiter found after quotelike $op",
		         pos $$textref;
		pos $$textref = $startpos;
		return;
	}
	pos($$textref) = $ld1pos;	# HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN
	my ($ldel1, $rdel1) = ("\Q$1","\Q$1");
	if ($ldel1 =~ /[[(<{]/)
	{
		$rdel1 =~ tr/[({</])}>/;
		defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1))
		|| do { pos $$textref = $startpos; return };
        $ld2pos = pos($$textref);
        $rd1pos = $ld2pos-1;
	}
	else
	{
		$$textref =~ /\G$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs
		|| do { pos $$textref = $startpos; return };
        $ld2pos = $rd1pos = pos($$textref)-1;
	}

	my $second_arg = $op =~ /s|tr|y/ ? 1 : 0;
	if ($second_arg)
	{
		my ($ldel2, $rdel2);
		if ($ldel1 =~ /[[(<{]/)
		{
			unless ($$textref =~ /\G\s*(\S)/gc)	# SHOULD USE LOOKAHEAD
			{
				_failmsg "Missing second block for quotelike $op",
					 pos $$textref;
				pos $$textref = $startpos;
				return;
			}
			$ldel2 = $rdel2 = "\Q$1";
			$rdel2 =~ tr/[({</])}>/;
		}
		else
		{
			$ldel2 = $rdel2 = $ldel1;
		}
		$str2pos = $ld2pos+1;

		if ($ldel2 =~ /[[(<{]/)
		{
			pos($$textref)--;	# OVERCOME BROKEN LOOKAHEAD 
			defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2))
			|| do { pos $$textref = $startpos; return };
		}
		else
		{
			$$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs
			|| do { pos $$textref = $startpos; return };
		}
		$rd2pos = pos($$textref)-1;
	}
	else
	{
		$ld2pos = $str2pos = $rd2pos = $rd1pos;
	}

	$modpos = pos $$textref;

	$$textref =~ m/\G($mods{$op})/gc;
	my $endpos = pos $$textref;

	return (
		$startpos,	$oppos-$startpos,	# PREFIX
		$oppos,		length($op),		# OPERATOR
		$ld1pos,	1,			# LEFT DEL
		$str1pos,	$rd1pos-$str1pos,	# STR/PAT
		$rd1pos,	1,			# RIGHT DEL
		$ld2pos,	$second_arg,		# 2ND LDEL (MAYBE)
		$str2pos,	$rd2pos-$str2pos,	# 2ND STR (MAYBE)
		$rd2pos,	$second_arg,		# 2ND RDEL (MAYBE)
		$modpos,	$endpos-$modpos,	# MODIFIERS
		$endpos,	$textlen-$endpos,	# REMAINDER
	       );
}

my $def_func = 
[
	sub { extract_variable($_[0], '') },
	sub { extract_quotelike($_[0],'') },
	sub { extract_codeblock($_[0],'{}','') },
];

sub extract_multiple (;$$$$)	# ($text, $functions_ref, $max_fields, $ignoreunknown)
{
	my $textref = defined($_[0]) ? \$_[0] : \$_;
	my $posbug = pos;
	my ($lastpos, $firstpos);
	my @fields = ();

	#for ($$textref)
	{
		my @func = defined $_[1] ? @{$_[1]} : @{$def_func};
		my $max  = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000;
		my $igunk = $_[3];

		pos $$textref ||= 0;

		unless (wantarray)
		{
			use Carp;
			carp "extract_multiple reset maximal count to 1 in scalar context"
				if $^W && defined($_[2]) && $max > 1;
			$max = 1
		}