Upgrade to NEXT 0.50.

p4raw-id: //depot/perl@13117

8 files changed, 350 insertions, 51 deletions

diff --git a/MANIFEST b/MANIFEST
index cfc6bbd458..42e4ab2de3 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1128,7 +1128,10 @@ lib/newgetopt.pl		A perl library supporting long option parsing
 lib/NEXT.pm			Pseudo-class NEXT for method redispatch
 lib/NEXT/Changes		NEXT
 lib/NEXT/README			NEXT
-lib/NEXT/test.pl		See if NEXT works
+lib/NEXT/t/actual.t		NEXT
+lib/NEXT/t/actuns.t		NEXT
+lib/NEXT/t/next.t		NEXT
+lib/NEXT/t/unseen.t		NEXT
 lib/open.pm			Pragma to specify default I/O disciplines
 lib/open.t			See if the open pragma works
 lib/open2.pl			Open a two-ended pipe (uses IPC::Open2)
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
diff --git a/lib/NEXT/Changes b/lib/NEXT/Changes
index bb5e27a7b8..f6f7bff1b2 100644
--- a/lib/NEXT/Changes
+++ b/lib/NEXT/Changes
@@ -20,3 +20,20 @@ Revision history for Perl extension NEXT.pm.
 	- Fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS (thanks Leonid)
 
 	- Changed licence for inclusion in core distribution
+
+
+0.50	Fri Nov 16 11:20:40 2001
+
+	- Added a $VERSION (oops!)
+
+	- Fixed handling of diamond patterns (thanks Paul)
+
+	- Added NEXT::ACTUAL to require existence of next method (thanks Paul)
+
+	- Added NEXT::UNSEEN to avoid calling multiply inherited
+	  methods twice (thanks Paul)
+
+	- Re-fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS to be
+	  consistent with more useful SUPER:: behaviour
+
+	- Corified tests
diff --git a/lib/NEXT/README b/lib/NEXT/README
index 7202d00fde..ad750bcdb4 100644
--- a/lib/NEXT/README
+++ b/lib/NEXT/README
@@ -1,5 +1,5 @@
 ==============================================================================
-                       Release of version 0.02 of NEXT
+                       Release of version 0.50 of NEXT
 ==============================================================================
 
 
@@ -31,10 +31,9 @@ DESCRIPTION
     redispatch that call, in the hope that some other C<AUTOLOAD>
     (above it, or to its left) might do better.
 
-    Note that it is a fatal error for any method (including C<AUTOLOAD>)
-    to attempt to redispatch any method except itself. For example:
-
-            sub D::oops { $_[0]->NEXT::other_method() } # BANG!
+    The module also allows you to specify that multiply inherited
+    methods should only be redispatched once, and what should
+    happen if no redispatch is possible.
 
 
 AUTHOR
@@ -51,12 +50,22 @@ COPYRIGHT
 
 ==============================================================================
 
-CHANGES IN VERSION 0.02
+CHANGES IN VERSION 0.50
+
+
+	- Added a $VERSION (oops!)
+
+	- Fixed handling of diamond patterns (thanks Paul)
+
+	- Added NEXT::ACTUAL to require existence of next method (thanks Paul)
 
+	- Added NEXT::UNSEEN to avoid calling multiply inherited
+	  methods twice (thanks Paul)
 
-	- Fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS (thanks Leonid)
+	- Re-fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS to be
+	  consistent with more useful SUPER:: behaviour
 
-	- Changed licence for inclusion in core distribution
+	- Corified tests
 
 
 ==============================================================================
diff --git a/lib/NEXT/t/actual.t b/lib/NEXT/t/actual.t
new file mode 100644
index 0000000000..e45184052b
--- /dev/null
+++ b/lib/NEXT/t/actual.t
@@ -0,0 +1,37 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
+BEGIN { print "1..9\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+eval { $foo->test } and print "not ";
+print "ok 9\n";
diff --git a/lib/NEXT/t/actuns.t b/lib/NEXT/t/actuns.t
new file mode 100644
index 0000000000..3795681bc2
--- /dev/null
+++ b/lib/NEXT/t/actuns.t
@@ -0,0 +1,37 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
+BEGIN { print "1..5\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+eval { $foo->test } and print "not ";
+print "ok 5\n";
diff --git a/lib/NEXT/test.pl b/lib/NEXT/t/next.t
index 0ba0b663bf..8cc493f318 100644
--- a/lib/NEXT/test.pl
+++ b/lib/NEXT/t/next.t
@@ -1,4 +1,9 @@
-#! /usr/local/bin/perl -w
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
 
 BEGIN { print "1..25\n"; }
 
diff --git a/lib/NEXT/t/unseen.t b/lib/NEXT/t/unseen.t
new file mode 100644
index 0000000000..af8d1f7612
--- /dev/null
+++ b/lib/NEXT/t/unseen.t
@@ -0,0 +1,36 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
+BEGIN { print "1..4\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+$foo->test;