next.pm

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

package NEXT;
$VERSION = '0.60_01';
use Carp;
use strict;

sub NEXT::ELSEWHERE::ancestors
{
	my @inlist = shift;
	my @outlist = ();
	while (my $next = shift @inlist) {
		push @outlist, $next;
		no strict 'refs';
		unshift @inlist, @{"$outlist[-1]::ISA"};
	}
	return @outlist;
}

sub NEXT::ELSEWHERE::ordered_ancestors
{
	my @inlist = shift;
	my @outlist = ();
	while (my $next = shift @inlist) {
		push @outlist, $next;
		no strict 'refs';
		push @inlist, @{"$outlist[-1]::ISA"};
	}
	return sort { $a->isa($b) ? -1
	            : $b->isa($a) ? +1
	            :                0 } @outlist;
}

sub AUTOLOAD
{
	my ($self) = @_;
	my $depth = 1;
	until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
	my $caller = (caller($depth))[3];
	my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
	undef $NEXT::AUTOLOAD;
	my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
	my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
	croak "Can't call $wanted from $caller"
		unless $caller_method eq $wanted_method;

	local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
	      ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);


	unless ($NEXT::NEXT{$self,$wanted_method}) {
		my @forebears =
			NEXT::ELSEWHERE::ancestors ref $self || $self,
						   $wanted_class;
		while (@forebears) {
			last if shift @forebears eq $caller_class
		}
		no strict 'refs';
		@{$NEXT::NEXT{$self,$wanted_method}} = 
			map { *{"${_}::$caller_method"}{CODE}||() } @forebears
				unless $wanted_method eq 'AUTOLOAD';
		@{$NEXT::NEXT{$self,$wanted_method}} = 
			map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
				unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
		$NEXT::SEEN->{$self,*{$caller}{CODE}}++;
	}
	my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
	while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
	       && defined $call_method
	       && $NEXT::SEEN->{$self,$call_method}++) {
		$call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
	}
	unless (defined $call_method) {
		return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
		(local $Carp::CarpLevel)++;
		croak qq(Can't locate object method "$wanted_method" ),
		      qq(via package "$caller_class");
	};
	return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
	no strict 'refs';
	($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
		if $wanted_method eq 'AUTOLOAD';
	$$call_method = $caller_class."::NEXT::".$wanted_method;
	return $call_method->(@_);
}

no strict 'vars';
package NEXT::UNSEEN;		@ISA = 'NEXT';
package NEXT::DISTINCT;		@ISA = 'NEXT';
package NEXT::ACTUAL;		@ISA = 'NEXT';
package NEXT::ACTUAL::UNSEEN;	@ISA = 'NEXT';
package NEXT::ACTUAL::DISTINCT;	@ISA = 'NEXT';
package NEXT::UNSEEN::ACTUAL;	@ISA = 'NEXT';
package NEXT::DISTINCT::ACTUAL;	@ISA = 'NEXT';

package EVERY::LAST;		@ISA = 'EVERY';
package EVERY;			@ISA = 'NEXT';
sub AUTOLOAD
{
	my ($self) = @_;
	my $depth = 1;
	until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
	my $caller = (caller($depth))[3];
	my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD';
	undef $EVERY::AUTOLOAD;
	my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;

	local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} =
	      $NEXT::ALREADY_IN_EVERY{$self,$wanted_method};

	return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++;
	
	my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
					                   $wanted_class;
	@forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
	no strict 'refs';
	my %seen;
	my @every = map { my $sub = "${_}::$wanted_method";
		          !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
		        } @forebears
				unless $wanted_method eq 'AUTOLOAD';

	my $want = wantarray;
	if (@every) {
		if ($want) {
			return map {($_, [$self->$_(@_[1..$#_])])} @every;
		}
		elsif (defined $want) {
			return { map {($_, scalar($self->$_(@_[1..$#_])))}
				     @every
			       };
		}
		else {
			$self->$_(@_[1..$#_]) for @every;
			return;
		}
	}

	@every = map { my $sub = "${_}::AUTOLOAD";
		       !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
		     } @forebears;
	if ($want) {
		return map { $$_ = ref($self)."::EVERY::".$wanted_method;
			     ($_, [$self->$_(@_[1..$#_])]);
			   } @every;
	}
	elsif (defined $want) {
		return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
			       ($_, scalar($self->$_(@_[1..$#_])))
			     } @every
		       };
	}
	else {
		for (@every) {
			$$_ = ref($self)."::EVERY::".$wanted_method;
			$self->$_(@_[1..$#_]);
		}
		return;
	}
}


1;

__END__

=head1 NAME

NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch


=head1 SYNOPSIS

    use NEXT;

    package A;
    sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
    sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }

    package B;
    use base qw( A );
    sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }

    package C;
    sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
    sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }

    package D;
    use base qw( B C );
    sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
    sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }

    package main;

    my $obj = bless {}, "D";

    $obj->method();		# Calls D::method, A::method, C::method
    $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD

    # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY



=head1 DESCRIPTION

NEXT.pm adds a pseudoclass named C<NEXT> to any program
that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
C<m> is redispatched as if the calling method had not originally been found.

In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
left-to-right search of C<$self>'s class hierarchy that resulted in the
original call to C<m>.

Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
begins a new dispatch that is restricted to searching the ancestors
of the current class. C<$self-E<gt>NEXT::m()> can backtrack
past the current class -- to look for a suitable method in other
ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.

A typical use would be in the destructors of a class hierarchy,
as illustrated in the synopsis above. Each class in the hierarchy
has a DESTROY method that performs some class-specific action
and then redispatches the call up the hierarchy. As a result,
when an object of class D is destroyed, the destructors of I<all>
its parent classes are called (in depth-first, left-to-right order).

Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
If such a method determined that it was not able to handle a
particular call, it might choose to redispatch that call, in the
hope that some other C<AUTOLOAD> (above it, or to its left) might
do better.

By default, if a redispatch attempt fails to find another method
elsewhere in the objects class hierarchy, it quietly gives up and does
nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
is also unlike the (generally annoying) behaviour of C<SUPER>, which
throws an exception if it cannot redispatch.

Note that it is a fatal error for any method (including C<AUTOLOAD>)
to attempt to redispatch any method that does not have the
same name. For example:

        sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }


=head2 Enforcing redispatch

It is possible to make C<NEXT> redispatch more demandingly (i.e. like
C<SUPER> does), so that the redispatch throws an exception if it cannot
find a "next" method to call.

To do this, simple invoke the redispatch as:

	$self->NEXT::ACTUAL::method();

rather than:

	$self->NEXT::method();

The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
or it should throw an exception.

C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure 
semantics:

	sub AUTOLOAD {
		if ($AUTOLOAD =~ /foo|bar/) {