Add NEXT, a pseudo-class for method redispatching.

<Damian>NEXT.pm probably offers more bang-for-buck
than anything else I've ever written.</Damian>

p4raw-id: //depot/perl@9938

1 files changed, 140 insertions, 0 deletions

diff --git a/lib/NEXT.pm b/lib/NEXT.pm
new file mode 100644
index 0000000000..144b145729
--- /dev/null
+++ b/lib/NEXT.pm
@@ -0,0 +1,140 @@
+package NEXT;
+use Carp;
+use strict;
+
+sub ancestors
+{
+	my @inlist = @_;
+	my @outlist = ();
+	while (@inlist) {
+		push @outlist, shift @inlist;
+		no strict 'refs';
+		unshift @inlist, @{"$outlist[-1]::ISA"};
+	}
+	return @outlist;
+}
+
+sub AUTOLOAD
+{
+	my ($self) = @_;
+	my $caller = (caller(1))[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::NEXT{$self,$wanted_method};
+
+	unless (@{$NEXT::NEXT{$self,$wanted_method}||[]}) {
+		my @forebears = ancestors ref $self;
+		while (@forebears) {
+			last if shift @forebears eq $caller_class
+		}
+		no strict 'refs';
+		@{$NEXT::NEXT{$self,$wanted_method}} = 
+			map { *{"${_}::$caller_method"}{CODE}||() } @forebears;
+		@{$NEXT::NEXT{$self,$wanted_method}} = 
+			map { *{"${_}::AUTOLOAD"}{CODE}||() } @forebears
+				unless @{$NEXT::NEXT{$self,$wanted_method}};
+	}
+	$wanted_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
+	return shift()->$wanted_method(@_) if $wanted_method;
+	return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+NEXT.pm - Provide a pseudo-class NEXT 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->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->NEXT::m()> resumes the depth-first,
+left-to-right search of parent classes that resulted in the original
+call to C<m>.
+
+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.
+
+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 { print "oops!\n"; $_[0]->NEXT::other_method() }
+
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org)
+
+=head1 BUGS AND IRRITATIONS
+
+Because it's a module, not an integral part of the interpreter, NEXT.pm
+has to guess where the surrounding call was found in the method
+look-up sequence. In the presence of diamond inheritance patterns
+it occasionally guesses wrong.
+
+It's also too slow (despite caching).
+
+Comment, suggestions, and patches welcome.
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2000, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+and/or modified under the terms of the Perl Artistic License
+     (see http://www.perl.com/perl/misc/Artistic.html)