Upgrade to NEXT 0.50.

p4raw-id: //depot/perl@13117

1 files changed, 196 insertions, 41 deletions

diff --git a/lib/NEXT.pm b/lib/NEXT.pm
index e41065c86d..68b3df2547 100644
--- a/lib/NEXT.pm
+++ b/lib/NEXT.pm
@@ -1,13 +1,14 @@
 package NEXT;
+$VERSION = '0.50';
 use Carp;
 use strict;
 
 sub ancestors
 {
-	my @inlist = @_;
+	my @inlist = shift;
 	my @outlist = ();
-	while (@inlist) {
-		push @outlist, shift @inlist;
+	while (my $next = shift @inlist) {
+		push @outlist, $next;
 		no strict 'refs';
 		unshift @inlist, @{"$outlist[-1]::ISA"};
 	}
@@ -25,11 +26,13 @@ sub AUTOLOAD
 	croak "Can't call $wanted from $caller"
 		unless $caller_method eq $wanted_method;
 
-	local $NEXT::NEXT{$self,$wanted_method} =
-	      $NEXT::NEXT{$self,$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 = ancestors ref $self;
+
+	unless ($NEXT::NEXT{$self,$wanted_method}) {
+		my @forebears =
+			ancestors ref $self || $self, $wanted_class;
 		while (@forebears) {
 			last if shift @forebears eq $caller_class
 		}
@@ -38,22 +41,34 @@ sub AUTOLOAD
 			map { *{"${_}::$caller_method"}{CODE}||() } @forebears
 				unless $wanted_method eq 'AUTOLOAD';
 		@{$NEXT::NEXT{$self,$wanted_method}} = 
-			map { (*{"${_}::AUTOLOAD"}{CODE}) ?
-						"${_}::AUTOLOAD" : () } @forebears
+			map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
 				unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
 	}
 	my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
-	return unless defined $call_method;
-	if (ref $call_method eq 'CODE') {
-		return shift()->$call_method(@_)
-	}
-	else {	# AN AUTOLOAD
-		no strict 'refs';
-		${$call_method} = $caller_method eq 'AUTOLOAD' && ${"${caller_class}::AUTOLOAD"} || $wanted;
-		return $call_method->(@_);
+	while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && 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 shift()->$call_method(@_) 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::ACTUAL;		@ISA = 'NEXT';
+package NEXT::ACTUAL::UNSEEN;	@ISA = 'NEXT';
+package NEXT::UNSEEN::ACTUAL;	@ISA = 'NEXT';
+
 1;
 
 __END__
@@ -65,36 +80,36 @@ NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
 
 =head1 SYNOPSIS
 
-	use NEXT;
+    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 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 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 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 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;
+    package main;
 
-	my $obj = bless {}, "D";
+    my $obj = bless {}, "D";
 
-	$obj->method();		# Calls D::method, A::method, C::method
-	$obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
+    $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
+    # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
 
 
 =head1 DESCRIPTION
@@ -126,10 +141,150 @@ 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 acquiesence
+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 except itself. For example:
+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/) {
+			# handle here
+		}
+		else {  # try elsewhere
+			shift()->NEXT::ACTUAL::AUTOLOAD(@_);
+		}
+	}
+
+By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
+method call, an exception will be thrown (as usually happens in the absence of
+a suitable C<AUTOLOAD>).
+
+
+=head2 Avoiding repetitions
+
+If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
+
+	#     A   B
+	#    / \ /
+	#   C   D
+	#    \ /
+	#     E
+
+	use NEXT;
+
+	package A;                 
+	sub foo { print "called A::foo\n"; shift->NEXT::foo() }
+
+	package B;                 
+	sub foo { print "called B::foo\n"; shift->NEXT::foo() }
+
+	package C; @ISA = qw( A );
+	sub foo { print "called C::foo\n"; shift->NEXT::foo() }
+
+	package D; @ISA = qw(A B);
+	sub foo { print "called D::foo\n"; shift->NEXT::foo() }
+
+	package E; @ISA = qw(C D);
+	sub foo { print "called E::foo\n"; shift->NEXT::foo() }
+
+	E->foo();
+
+then derived classes may (re-)inherit base-class methods through two or
+more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
+through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
+will invoke the multiply inherited method as many times as it is
+inherited. For example, the above code prints:
+
+        called E::foo
+        called C::foo
+        called A::foo
+        called D::foo
+        called A::foo
+        called B::foo
+
+(i.e. C<A::foo> is called twice).
+
+In some cases this I<may> be the desired effect within a diamond hierarchy,
+but in others (e.g. for destructors) it may be more appropriate to 
+call each method only once during a sequence of redispatches.
+
+To cover such cases, you can redispatch methods via:
+
+        $self->NEXT::UNSEEN::method();
+
+rather than:
+
+        $self->NEXT::method();
+
+This causes the redispatcher to skip any classes in the hierarchy that it has
+already visited in an earlier redispatch. So, for example, if the
+previous example were rewritten:
+
+        package A;                 
+        sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+        package B;                 
+        sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+        package C; @ISA = qw( A );
+        sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+        package D; @ISA = qw(A B);
+        sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+        package E; @ISA = qw(C D);
+        sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+        E->foo();
+
+then it would print:
+        
+        called E::foo
+        called C::foo
+        called A::foo
+        called D::foo
+        called B::foo
+
+and omit the second call to C<A::foo>.
+
+Note that you can also use:
+
+        $self->NEXT::UNSEEN::ACTUAL::method();
+
+or:
+
+        $self->NEXT::ACTUAL::UNSEEN::method();
 
-	sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+to get both unique invocation I<and> exception-on-failure.
 
 
 =head1 AUTHOR