balanced.pm

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

		my $unkpos;
		my $func;
		my $class;

		my @class;
		foreach $func ( @func )
		{
			if (ref($func) eq 'HASH')
			{
				push @class, (keys %$func)[0];
				$func = (values %$func)[0];
			}
			else
			{
				push @class, undef;
			}
		}

		FIELD: while (pos($$textref) < length($$textref))
		{
			my ($field, $rem);
			my @bits;
			foreach my $i ( 0..$#func )
			{
				my $pref;
				$func = $func[$i];
				$class = $class[$i];
				$lastpos = pos $$textref;
				if (ref($func) eq 'CODE')
					{ ($field,$rem,$pref) = @bits = $func->($$textref) }
				elsif (ref($func) eq 'Text::Balanced::Extractor')
					{ @bits = $field = $func->extract($$textref) }
				elsif( $$textref =~ m/\G$func/gc )
					{ @bits = $field = defined($1)
                                ? $1
                                : substr($$textref, $-[0], $+[0] - $-[0])
                    }
				$pref ||= "";
				if (defined($field) && length($field))
				{
					if (!$igunk) {
						$unkpos = $lastpos
							if length($pref) && !defined($unkpos);
						if (defined $unkpos)
						{
							push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref;
							$firstpos = $unkpos unless defined $firstpos;
							undef $unkpos;
							last FIELD if @fields == $max;
						}
					}
					push @fields, $class
						? bless (\$field, $class)
						: $field;
					$firstpos = $lastpos unless defined $firstpos;
					$lastpos = pos $$textref;
					last FIELD if @fields == $max;
					next FIELD;
				}
			}
			if ($$textref =~ /\G(.)/gcs)
			{
				$unkpos = pos($$textref)-1
					unless $igunk || defined $unkpos;
			}
		}
		
		if (defined $unkpos)
		{
			push @fields, substr($$textref, $unkpos);
			$firstpos = $unkpos unless defined $firstpos;
			$lastpos = length $$textref;
		}
		last;
	}

	pos $$textref = $lastpos;
	return @fields if wantarray;

	$firstpos ||= 0;
	eval { substr($$textref,$firstpos,$lastpos-$firstpos)="";
	       pos $$textref = $firstpos };
	return $fields[0];
}


sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options)
{
	my $ldel    = $_[0];
	my $rdel    = $_[1];
	my $pre     = defined $_[2] ? $_[2] : '\s*';
	my %options = defined $_[3] ? %{$_[3]} : ();
	my $omode   = defined $options{fail} ? $options{fail} : '';
	my $bad     = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
		    : defined($options{reject})	       ? $options{reject}
		    :					 ''
		    ;
	my $ignore  = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}})
		    : defined($options{ignore})	       ? $options{ignore}
		    :					 ''
		    ;

	if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; }

	my $posbug = pos;
	for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ }
	pos = $posbug;

	my $closure = sub
	{
		my $textref = defined $_[0] ? \$_[0] : \$_;
		my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);

		return _fail(wantarray, $textref) unless @match;
		return _succeed wantarray, $textref,
				$match[2], $match[3]+$match[5]+$match[7],	# MATCH
				@match[8..9,0..1,2..7];				# REM, PRE, BITS
	};

	bless $closure, 'Text::Balanced::Extractor';
}

package Text::Balanced::Extractor;

sub extract($$)	# ($self, $text)
{
	&{$_[0]}($_[1]);
}

package Text::Balanced::ErrorMsg;

use overload '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" };

1;

__END__

=head1 NAME

Text::Balanced - Extract delimited text sequences from strings.


=head1 SYNOPSIS

 use Text::Balanced qw (
			extract_delimited
			extract_bracketed
			extract_quotelike
			extract_codeblock
			extract_variable
			extract_tagged
			extract_multiple

			gen_delimited_pat
			gen_extract_tagged
		       );

 # Extract the initial substring of $text that is delimited by
 # two (unescaped) instances of the first character in $delim.

	($extracted, $remainder) = extract_delimited($text,$delim);


 # Extract the initial substring of $text that is bracketed
 # with a delimiter(s) specified by $delim (where the string
 # in $delim contains one or more of '(){}[]<>').

	($extracted, $remainder) = extract_bracketed($text,$delim);


 # Extract the initial substring of $text that is bounded by
 # an XML tag.

	($extracted, $remainder) = extract_tagged($text);


 # Extract the initial substring of $text that is bounded by
 # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags

	($extracted, $remainder) =
		extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]});


 # Extract the initial substring of $text that represents a
 # Perl "quote or quote-like operation"

	($extracted, $remainder) = extract_quotelike($text);


 # Extract the initial substring of $text that represents a block
 # of Perl code, bracketed by any of character(s) specified by $delim
 # (where the string $delim contains one or more of '(){}[]<>').

	($extracted, $remainder) = extract_codeblock($text,$delim);


 # Extract the initial substrings of $text that would be extracted by
 # one or more sequential applications of the specified functions
 # or regular expressions

	@extracted = extract_multiple($text,
				      [ \&extract_bracketed,
					\&extract_quotelike,
					\&some_other_extractor_sub,
					qr/[xyz]*/,
					'literal',
				      ]);

# Create a string representing an optimized pattern (a la Friedl)
# that matches a substring delimited by any of the specified characters
# (in this case: any type of quote or a slash)

	$patstring = gen_delimited_pat(q{'"`/});


# Generate a reference to an anonymous sub that is just like extract_tagged
# but pre-compiled and optimized for a specific pair of tags, and consequently
# much faster (i.e. 3 times faster). It uses qr// for better performance on
# repeated calls, so it only works under Perl 5.005 or later.

	$extract_head = gen_extract_tagged('<HEAD>','</HEAD>');

	($extracted, $remainder) = $extract_head->($text);


=head1 DESCRIPTION

The various C<extract_...> subroutines may be used to
extract a delimited substring, possibly after skipping a
specified prefix string. By default, that prefix is
optional whitespace (C</\s*/>), but you can change it to whatever
you wish (see below).

The substring to be extracted must appear at the
current C<pos> location of the string's variable
(or at index zero, if no C<pos> position is defined).
In other words, the C<extract_...> subroutines I<don't>
extract the first occurrence of a substring anywhere
in a string (like an unanchored regex would). Rather,
they extract an occurrence of the substring appearing
immediately at the current matching position in the
string (like a C<\G>-anchored regex would).



=head2 General behaviour in list contexts

In a list context, all the subroutines return a list, the first three
elements of which are always:

=over 4

=item [0]

The extracted string, including the specified delimiters.
If the extraction fails C<undef> is returned.

=item [1]

The remainder of the input string (i.e. the characters after the
extracted string). On failure, the entire string is returned.

=item [2]

The skipped prefix (i.e. the characters before the extracted string).
On failure, C<undef> is returned.

=back 

Note that in a list context, the contents of the original input text (the first
argument) are not modified in any way. 

However, if the input text was passed in a variable, that variable's
C<pos> value is updated to point at the first character after the
extracted text. That means that in a list context the various
subroutines can be used much like regular expressions. For example:

	while ( $next = (extract_quotelike($text))[0] )
	{
		# process next quote-like (in $next)
	}


=head2 General behaviour in scalar and void contexts

In a scalar context, the extracted string is returned, having first been
removed from the input text. Thus, the following code also processes
each quote-like operation, but actually removes them from $text:

	while ( $next = extract_quotelike($text) )
	{
		# process next quote-like (in $next)
	}

Note that if the input text is a read-only string (i.e. a literal),
no attempt is made to remove the extracted text.

In a void context the behaviour of the extraction subroutines is
exactly the same as in a scalar context, except (of course) that the
extracted substring is not returned.

=head2 A note about prefixes

Prefix patterns are matched without any trailing modifiers (C</gimsox> etc.)
This can bite you if you're expecting a prefix specification like
'.*?(?=<H1>)' to skip everything up to the first <H1> tag. Such a prefix
pattern will only succeed if the <H1> tag is on the current line, since
. normally doesn't match newlines.

To overcome this limitation, you need to turn on /s matching within
the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=<H1>)'


=head2 C<extract_delimited>

The C<extract_delimited> function formalizes the common idiom
of extracting a single-character-delimited substring from the start of
a string. For example, to extract a single-quote delimited string, the
following code is typically used:

	($remainder = $text) =~ s/\A('(\\.|[^'])*')//s;
	$extracted = $1;

but with C<extract_delimited> it can be simplified to:

	($extracted,$remainder) = extract_delimited($text, "'");

C<extract_delimited> takes up to four scalars (the input text, the
delimiters, a prefix pattern to be skipped, and any escape characters)
and extracts the initial substring of the text that
is appropriately delimited. If the delimiter string has multiple
characters, the first one encountered in the text is taken to delimit
the substring.
The third argument specifies a prefix pattern that is to be skipped
(but must be present!) before the substring is extracted.
The final argument specifies the escape character to be used for each
delimiter.

All arguments are optional. If the escape characters are not specified,
every delimiter is escaped with a backslash (C<\>).
If the prefix is not specified, the
pattern C<'\s*'> - optional whitespace - is used. If the delimiter set
is also not specified, the set C</["'`]/> is used. If the text to be processed
is not specified either, C<$_> is used.

In list context, C<extract_delimited> returns a array of three
elements, the extracted substring (I<including the surrounding
delimiters>), the remainder of the text, and the skipped prefix (if
any). If a suitable delimited substring is not found, the first
element of the array is the empty string, the second is the complete
original text, and the prefix returned in the third element is an
empty string.

In a scalar context, just the extracted substring is returned. In
a void context, the extracted substring (and any prefix) are simply
removed from the beginning of the first argument.

Examples:

	# Remove a single-quoted substring from the very beginning of $text:

		$substring = extract_delimited($text, "'", '');

	# Remove a single-quoted Pascalish substring (i.e. one in which
	# doubling the quote character escapes it) from the very
	# beginning of $text:

		$substring = extract_delimited($text, "'", '', "'");

	# Extract a single- or double- quoted substring from the
	# beginning of $text, optionally after some whitespace
	# (note the list context to protect $text from modification):

		($substring) = extract_delimited $text, q{"'};


	# Delete the substring delimited by the first '/' in $text:

		$text = join '', (extract_delimited($text,'/','[^/]*')[2,1];

Note that this last example is I<not> the same as deleting the first
quote-like pattern. For instance, if C<$text> contained the string:

	"if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }"
	
then after the deletion it would contain:

	"if ('.$UNIXCMD/s) { $cmd = $1; }"

not:

	"if ('./cmd' =~ ms) { $cmd = $1; }"
	

See L<"extract_quotelike"> for a (partial) solution to this problem.


=head2 C<extract_bracketed>

Like C<"extract_delimited">, the C<extract_bracketed> function takes
up to three optional scalar arguments: a string to extract from, a delimiter
specifier, and a prefix pattern. As before, a missing prefix defaults to
optional whitespace and a missing text defaults to C<$_>. However, a missing
delimiter specifier defaults to C<'{}()[]E<lt>E<gt>'> (see below).

C<extract_bracketed> extracts a balanced-bracket-delimited
substring (using any one (or more) of the user-specified delimiter
brackets: '(..)', '{..}', '[..]', or '<..>'). Optionally it will also
respect quoted unbalanced brackets (see below).

A "delimiter bracket" is a bracket in list of delimiters passed as
C<extract_bracketed>'s second argument. Delimiter brackets are
specified by giving either the left or right (or both!) versions
of the required bracket(s). Note that the order in which
two or more delimiter brackets are specified is not significant.

A "balanced-bracket-delimited substring" is a substring bounded by
matched brackets, such that any other (left or right) delimiter
bracket I<within> the substring is also matched by an opposite
(right or left) delimiter bracket I<at the same level of nesting>. Any
type of bracket not in the delimiter list is treated as an ordinary
character.

In other words, each type of bracket specified as a delimiter must be
balanced and correctly nested within the substring, and any other kind of
("non-delimiter") bracket in the substring is ignored.

For example, given the string:

	$text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }";

then a call to C<extract_bracketed> in a list context:

	@result = extract_bracketed( $text, '{}' );

would return:

	( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" )

since both sets of C<'{..}'> brackets are properly nested and evenly balanced.
(In a scalar context just the first element of the array would be returned. In
a void context, C<$text> would be replaced by an empty string.)

Likewise the call in:

	@result = extract_bracketed( $text, '{[' );