[perl5.git] / lib / NEXT.pm

package NEXT;
$VERSION = '0.60';
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 $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::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 $caller = (caller(1))[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 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 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::DISTINCT::method();

rather than:

        $self->NEXT::method();

This causes the redispatcher to only visit each distinct C<method> method
once. That is, to skip any classes in the hierarchy that it has
already visited during redispatch. So, for example, if the
previous example were rewritten:

        package A;                 
        sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }

        package B;                 
        sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }

        package C; @ISA = qw( A );
        sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }

        package D; @ISA = qw(A B);
        sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }

        package E; @ISA = qw(C D);
        sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::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> (since it would not be distinct
from the first call to C<A::foo>).

Note that you can also use:

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

or:

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

to get both unique invocation I<and> exception-on-failure.

Note that, for historical compatibility, you can also use
C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.


=head2 Invoking all versions of a method with a single call

Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
Its behaviour is considerably simpler than that of the C<NEXT> family.
A call to:

	$obj->EVERY::foo();

calls I<every> method named C<foo> that the object in C<$obj> has inherited.
That is:

	use NEXT;

	package A; @ISA = qw(B D X);
	sub foo { print "A::foo " }

	package B; @ISA = qw(D X);
	sub foo { print "B::foo " }

	package X; @ISA = qw(D);
	sub foo { print "X::foo " }

	package D;
	sub foo { print "D::foo " }

	package main;

	my $obj = bless {}, 'A';
	$obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo

Prefixing a method call with C<EVERY::> causes every method in the
object's hierarchy with that name to be invoked. As the above example
illustrates, they are not called in Perl's usual "left-most-depth-first"
order. Instead, they are called "breadth-first-dependency-wise".

That means that the inheritance tree of the object is traversed breadth-first
and the resulting order of classes is used as the sequence in which methods
are called. However, that sequence is modified by imposing a rule that the
appropritae method of a derived class must be called before the same method of
any ancestral class. That's why, in the above example, C<X::foo> is called
before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.

In general, there's no need to worry about the order of calls. They will be
left-to-right, breadth-first, most-derived-first. This works perfectly for
most inherited methods (including destructors), but is inappropriate for
some kinds of methods (such as constructors, cloners, debuggers, and
initializers) where it's more appropriate that the least-derived methods be
called first (as more-derived methods may rely on the behaviour of their
"ancestors"). In that case, instead of using the C<EVERY> pseudo-class:

	$obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo      

you can use the C<EVERY::LAST> pseudo-class:

	$obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo      

which reverses the order of method call.

Whichever version is used, the actual methods are called in the same
context (list, scalar, or void) as the original call via C<EVERY>, and return:

=over

=item *

A hash of array references in list context. Each entry of the hash has the
fully qualified method name as its key and a reference to an array containing
the method's list-context return values as its value.

=item *

A reference to a hash of scalar values in scalar context. Each entry of the hash has the
fully qualified method name as its key and the method's scalar-context return values as its value.

=item *

Nothing in void context (obviously).

=back

=head2 Using C<EVERY> methods

The typical way to use an C<EVERY> call is to wrap it in another base
method, that all classes inherit. For example, to ensure that every
destructor an object inherits is actually called (as opposed to just the
left-most-depth-first-est one):

        package Base;
        sub DESTROY { $_[0]->EVERY::Destroy }

        package Derived1; 
        use base 'Base';
        sub Destroy {...}

        package Derived2; 
        use base 'Base', 'Derived1';
        sub Destroy {...}

et cetera. Every derived class than needs its own clean-up
behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
which the call to C<EVERY::LAST::Destroy> in the inherited destructor
then correctly picks up.

Likewise, to create a class hierarchy in which every initializer inherited by
a new object is invoked:

        package Base;
        sub new {
		my ($class, %args) = @_;
		my $obj = bless {}, $class;
		$obj->EVERY::LAST::Init(\%args);
	}

        package Derived1; 
        use base 'Base';
        sub Init {
		my ($argsref) = @_;
		...
	}

        package Derived2; 
        use base 'Base', 'Derived1';
        sub Init {
		my ($argsref) = @_;
		...
	}

et cetera. Every derived class than needs some additional initialization
behaviour simply adds its own C<Init> method (I<not> a C<new> method),
which the call to C<EVERY::LAST::Init> in the inherited constructor
then correctly picks up.


=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-2001, Damian Conway. All Rights Reserved.
 This module is free software. It may be used, redistributed
    and/or modified under the same terms as Perl itself.
Commit	Line	Data
e4783b1c	1	package NEXT;
bf5734d4	2	$VERSION = '0.60';
e4783b1c JH	3	use Carp;
	4	use strict;
	5
52138ef3	6	sub NEXT::ELSEWHERE::ancestors
e4783b1c	7	{
13021a80	8	my @inlist = shift;
e4783b1c	9	my @outlist = ();
13021a80 JH	10	while (my $next = shift @inlist) {
13021a80 JH	11	push @outlist, $next;
e4783b1c JH	12	no strict 'refs';
	13	unshift @inlist, @{"$outlist[-1]::ISA"};
	14	}
	15	return @outlist;
	16	}
	17
bf5734d4 JH	18	sub NEXT::ELSEWHERE::ordered_ancestors
	19	{
	20	my @inlist = shift;
	21	my @outlist = ();
	22	while (my $next = shift @inlist) {
	23	push @outlist, $next;
	24	no strict 'refs';
	25	push @inlist, @{"$outlist[-1]::ISA"};
	26	}
	27	return sort { $a->isa($b) ? -1
	28	: $b->isa($a) ? +1
	29	: 0 } @outlist;
	30	}
	31
e4783b1c JH	32	sub AUTOLOAD
	33	{
	34	my ($self) = @_;
	35	my $caller = (caller(1))[3];
	36	my $wanted = $NEXT::AUTOLOAD \|\| 'NEXT::AUTOLOAD';
	37	undef $NEXT::AUTOLOAD;
	38	my ($caller_class, $caller_method) = $caller =~ m{(.)::(.)}g;
	39	my ($wanted_class, $wanted_method) = $wanted =~ m{(.)::(.)}g;
	40	croak "Can't call $wanted from $caller"
	41	unless $caller_method eq $wanted_method;
	42
13021a80 JH	43	local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
13021a80 JH	44	($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
e4783b1c	45
13021a80 JH	46
	47	unless ($NEXT::NEXT{$self,$wanted_method}) {
	48	my @forebears =
52138ef3 JH	49	NEXT::ELSEWHERE::ancestors ref $self \|\| $self,
52138ef3 JH	50	$wanted_class;
e4783b1c JH	51	while (@forebears) {
	52	last if shift @forebears eq $caller_class
	53	}
	54	no strict 'refs';
	55	@{$NEXT::NEXT{$self,$wanted_method}} =
55a1c97c JH	56	map { *{"${_}::$caller_method"}{CODE}\|\|() } @forebears
55a1c97c JH	57	unless $wanted_method eq 'AUTOLOAD';
e4783b1c	58	@{$NEXT::NEXT{$self,$wanted_method}} =
13021a80	59	map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
55a1c97c	60	unless @{$NEXT::NEXT{$self,$wanted_method}\|\|[]};
52138ef3	61	$NEXT::SEEN->{$self,*{$caller}{CODE}}++;
55a1c97c JH	62	}
55a1c97c JH	63	my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
bf5734d4 JH	64	while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN\|DISTINCT)\b/
bf5734d4 JH	65	&& defined $call_method
13021a80 JH	66	&& $NEXT::SEEN->{$self,$call_method}++) {
13021a80 JH	67	$call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
e4783b1c	68	}
13021a80 JH	69	unless (defined $call_method) {
	70	return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
	71	(local $Carp::CarpLevel)++;
	72	croak qq(Can't locate object method "$wanted_method" ),
	73	qq(via package "$caller_class");
	74	};
52138ef3	75	return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
13021a80 JH	76	no strict 'refs';
	77	($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
	78	if $wanted_method eq 'AUTOLOAD';
	79	$$call_method = $caller_class."::NEXT::".$wanted_method;
	80	return $call_method->(@_);
e4783b1c JH	81	}
e4783b1c JH	82
13021a80 JH	83	no strict 'vars';
13021a80 JH	84	package NEXT::UNSEEN; @ISA = 'NEXT';
52138ef3	85	package NEXT::DISTINCT; @ISA = 'NEXT';
13021a80 JH	86	package NEXT::ACTUAL; @ISA = 'NEXT';
13021a80 JH	87	package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
52138ef3	88	package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
13021a80	89	package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
52138ef3	90	package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
bf5734d4 JH	91
bf5734d4 JH	92	package EVERY::LAST; @ISA = 'EVERY';
52138ef3	93	package EVERY; @ISA = 'NEXT';
bf5734d4 JH	94	sub AUTOLOAD
	95	{
	96	my ($self) = @_;
	97	my $caller = (caller(1))[3];
	98	my $wanted = $EVERY::AUTOLOAD \|\| 'EVERY::AUTOLOAD';
	99	undef $EVERY::AUTOLOAD;
	100	my ($wanted_class, $wanted_method) = $wanted =~ m{(.)::(.)}g;
	101
	102	local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} =
	103	$NEXT::ALREADY_IN_EVERY{$self,$wanted_method};
	104
	105	return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++;
	106
	107	my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self \|\| $self,
	108	$wanted_class;
	109	@forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
	110	no strict 'refs';
	111	my %seen;
	112	my @every = map { my $sub = "${_}::$wanted_method";
	113	!*{$sub}{CODE} \|\| $seen{$sub}++ ? () : $sub
	114	} @forebears
	115	unless $wanted_method eq 'AUTOLOAD';
	116
	117	my $want = wantarray;
	118	if (@every) {
	119	if ($want) {
	120	return map {($_, [$self->$_(@_[1..$#_])])} @every;
	121	}
	122	elsif (defined $want) {
	123	return { map {($_, scalar($self->$_(@_[1..$#_])))}
	124	@every
	125	};
	126	}
	127	else {
	128	$self->$_(@_[1..$#_]) for @every;
	129	return;
	130	}
	131	}
	132
	133	@every = map { my $sub = "${_}::AUTOLOAD";
	134	!*{$sub}{CODE} \|\| $seen{$sub}++ ? () : "${_}::AUTOLOAD"
	135	} @forebears;
	136	if ($want) {
	137	return map { $$_ = ref($self)."::EVERY::".$wanted_method;
	138	($_, [$self->$_(@_[1..$#_])]);
	139	} @every;
	140	}
	141	elsif (defined $want) {
	142	return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
	143	($_, scalar($self->$_(@_[1..$#_])))
	144	} @every
	145	};
	146	}
	147	else {
	148	for (@every) {
	149	$$_ = ref($self)."::EVERY::".$wanted_method;
	150	$self->$_(@_[1..$#_]);
	151	}
	152	return;
	153	}
	154	}
	155
13021a80	156
e4783b1c JH	157	1;
	158
	159	__END__
	160
	161	=head1 NAME
	162
bf5734d4	163	NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
e4783b1c JH	164
	165
	166	=head1 SYNOPSIS
	167
13021a80	168	use NEXT;
e4783b1c	169
13021a80 JH	170	package A;
	171	sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
	172	sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	173
13021a80 JH	174	package B;
	175	use base qw( A );
	176	sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
	177	sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	178
13021a80 JH	179	package C;
	180	sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
	181	sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
	182	sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	183
13021a80 JH	184	package D;
	185	use base qw( B C );
	186	sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
	187	sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
	188	sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
e4783b1c	189
13021a80	190	package main;
e4783b1c	191
13021a80	192	my $obj = bless {}, "D";
e4783b1c	193
13021a80 JH	194	$obj->method(); # Calls D::method, A::method, C::method
13021a80 JH	195	$obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
e4783b1c	196
13021a80	197	# Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
e4783b1c JH	198
e4783b1c JH	199
bf5734d4	200
e4783b1c JH	201	=head1 DESCRIPTION
	202
	203	NEXT.pm adds a pseudoclass named C<NEXT> to any program
e23eab12	204	that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
e4783b1c JH	205	C<m> is redispatched as if the calling method had not originally been found.
e4783b1c JH	206
e23eab12	207	In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
55a1c97c JH	208	left-to-right search of C<$self>'s class hierarchy that resulted in the
	209	original call to C<m>.
	210
e23eab12	211	Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
55a1c97c	212	begins a new dispatch that is restricted to searching the ancestors
e23eab12	213	of the current class. C<$self-E<gt>NEXT::m()> can backtrack
55a1c97c	214	past the current class -- to look for a suitable method in other
e23eab12	215	ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
e4783b1c JH	216
	217	A typical use would be in the destructors of a class hierarchy,
	218	as illustrated in the synopsis above. Each class in the hierarchy
	219	has a DESTROY method that performs some class-specific action
	220	and then redispatches the call up the hierarchy. As a result,
	221	when an object of class D is destroyed, the destructors of I<all>
	222	its parent classes are called (in depth-first, left-to-right order).
	223
	224	Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
	225	If such a method determined that it was not able to handle a
	226	particular call, it might choose to redispatch that call, in the
	227	hope that some other C<AUTOLOAD> (above it, or to its left) might
	228	do better.
	229
13021a80 JH	230	By default, if a redispatch attempt fails to find another method
	231	elsewhere in the objects class hierarchy, it quietly gives up and does
	232	nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
	233	is also unlike the (generally annoying) behaviour of C<SUPER>, which
	234	throws an exception if it cannot redispatch.
	235
e4783b1c	236	Note that it is a fatal error for any method (including C<AUTOLOAD>)
13021a80 JH	237	to attempt to redispatch any method that does not have the
	238	same name. For example:
	239
	240	sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
	241
	242
	243	=head2 Enforcing redispatch
	244
	245	It is possible to make C<NEXT> redispatch more demandingly (i.e. like
	246	C<SUPER> does), so that the redispatch throws an exception if it cannot
	247	find a "next" method to call.
	248
	249	To do this, simple invoke the redispatch as:
	250
	251	$self->NEXT::ACTUAL::method();
	252
	253	rather than:
	254
	255	$self->NEXT::method();
	256
	257	The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
	258	or it should throw an exception.
	259
	260	C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
	261	decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
	262	semantics:
	263
	264	sub AUTOLOAD {
	265	if ($AUTOLOAD =~ /foo\|bar/) {
	266	# handle here
	267	}
	268	else { # try elsewhere
	269	shift()->NEXT::ACTUAL::AUTOLOAD(@_);
	270	}
	271	}
	272
	273	By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
	274	method call, an exception will be thrown (as usually happens in the absence of
	275	a suitable C<AUTOLOAD>).
	276
	277
	278	=head2 Avoiding repetitions
	279
	280	If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
	281
	282	# A B
	283	# / \ /
	284	# C D
	285	# \ /
	286	# E
	287
	288	use NEXT;
	289
	290	package A;
	291	sub foo { print "called A::foo\n"; shift->NEXT::foo() }
	292
	293	package B;
	294	sub foo { print "called B::foo\n"; shift->NEXT::foo() }
	295
	296	package C; @ISA = qw( A );
	297	sub foo { print "called C::foo\n"; shift->NEXT::foo() }
	298
	299	package D; @ISA = qw(A B);
	300	sub foo { print "called D::foo\n"; shift->NEXT::foo() }
301
302	package E; @ISA = qw(C D);
303	sub foo { print "called E::foo\n"; shift->NEXT::foo() }
304
305	E->foo();
306
307	then derived classes may (re-)inherit base-class methods through two or
308	more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
309	through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
310	will invoke the multiply inherited method as many times as it is
311	inherited. For example, the above code prints:
312
313	called E::foo
314	called C::foo
315	called A::foo
316	called D::foo
317	called A::foo
318	called B::foo
319
320	(i.e. C<A::foo> is called twice).
321
322	In some cases this I<may> be the desired effect within a diamond hierarchy,
323	but in others (e.g. for destructors) it may be more appropriate to
324	call each method only once during a sequence of redispatches.
325
326	To cover such cases, you can redispatch methods via:
327
52138ef3	328	$self->NEXT::DISTINCT::method();
13021a80 JH	329
	330	rather than:
	331
	332	$self->NEXT::method();
	333
52138ef3 JH	334	This causes the redispatcher to only visit each distinct C<method> method
	335	once. That is, to skip any classes in the hierarchy that it has
	336	already visited during redispatch. So, for example, if the
13021a80 JH	337	previous example were rewritten:
	338
	339	package A;
52138ef3	340	sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 JH	341
13021a80 JH	342	package B;
52138ef3	343	sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 JH	344
13021a80 JH	345	package C; @ISA = qw( A );
52138ef3	346	sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 JH	347
13021a80 JH	348	package D; @ISA = qw(A B);
52138ef3	349	sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 JH	350
13021a80 JH	351	package E; @ISA = qw(C D);
52138ef3	352	sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 JH	353
	354	E->foo();
	355
	356	then it would print:
	357
	358	called E::foo
	359	called C::foo
	360	called A::foo
	361	called D::foo
	362	called B::foo
	363
52138ef3 JH	364	and omit the second call to C<A::foo> (since it would not be distinct
52138ef3 JH	365	from the first call to C<A::foo>).
13021a80 JH	366
	367	Note that you can also use:
	368
52138ef3	369	$self->NEXT::DISTINCT::ACTUAL::method();
13021a80 JH	370
	371	or:
	372
52138ef3	373	$self->NEXT::ACTUAL::DISTINCT::method();
e4783b1c	374
13021a80	375	to get both unique invocation I<and> exception-on-failure.
e4783b1c	376
52138ef3 JH	377	Note that, for historical compatibility, you can also use
52138ef3 JH	378	C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
e4783b1c	379
bf5734d4 JH	380
	381	=head2 Invoking all versions of a method with a single call
	382
	383	Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
	384	Its behaviour is considerably simpler than that of the C<NEXT> family.
	385	A call to:
	386
	387	$obj->EVERY::foo();
	388
	389	calls I<every> method named C<foo> that the object in C<$obj> has inherited.
	390	That is:
	391
	392	use NEXT;
	393
	394	package A; @ISA = qw(B D X);
	395	sub foo { print "A::foo " }
	396
	397	package B; @ISA = qw(D X);
	398	sub foo { print "B::foo " }
	399
	400	package X; @ISA = qw(D);
	401	sub foo { print "X::foo " }
	402
	403	package D;
	404	sub foo { print "D::foo " }
	405
	406	package main;
	407
	408	my $obj = bless {}, 'A';
	409	$obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
	410
	411	Prefixing a method call with C<EVERY::> causes every method in the
	412	object's hierarchy with that name to be invoked. As the above example
	413	illustrates, they are not called in Perl's usual "left-most-depth-first"
	414	order. Instead, they are called "breadth-first-dependency-wise".
	415
	416	That means that the inheritance tree of the object is traversed breadth-first
	417	and the resulting order of classes is used as the sequence in which methods
	418	are called. However, that sequence is modified by imposing a rule that the
	419	appropritae method of a derived class must be called before the same method of
	420	any ancestral class. That's why, in the above example, C<X::foo> is called
	421	before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
	422
	423	In general, there's no need to worry about the order of calls. They will be
	424	left-to-right, breadth-first, most-derived-first. This works perfectly for
	425	most inherited methods (including destructors), but is inappropriate for
	426	some kinds of methods (such as constructors, cloners, debuggers, and
	427	initializers) where it's more appropriate that the least-derived methods be
	428	called first (as more-derived methods may rely on the behaviour of their
	429	"ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
	430
	431	$obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
	432
	433	you can use the C<EVERY::LAST> pseudo-class:
	434
	435	$obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
	436
	437	which reverses the order of method call.
	438
	439	Whichever version is used, the actual methods are called in the same
	440	context (list, scalar, or void) as the original call via C<EVERY>, and return:
	441
	442	=over
	443
444	=item *
445
446	A hash of array references in list context. Each entry of the hash has the
447	fully qualified method name as its key and a reference to an array containing
448	the method's list-context return values as its value.
449
450	=item *
451
452	A reference to a hash of scalar values in scalar context. Each entry of the hash has the
453	fully qualified method name as its key and the method's scalar-context return values as its value.
454
455	=item *
456
457	Nothing in void context (obviously).
458
459	=back
460
461	=head2 Using C<EVERY> methods
462
463	The typical way to use an C<EVERY> call is to wrap it in another base
464	method, that all classes inherit. For example, to ensure that every
465	destructor an object inherits is actually called (as opposed to just the
466	left-most-depth-first-est one):
467
468	package Base;
469	sub DESTROY { $_[0]->EVERY::Destroy }
470
471	package Derived1;
472	use base 'Base';
473	sub Destroy {...}
474
475	package Derived2;
476	use base 'Base', 'Derived1';
477	sub Destroy {...}
478
479	et cetera. Every derived class than needs its own clean-up
480	behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
481	which the call to C<EVERY::LAST::Destroy> in the inherited destructor
482	then correctly picks up.
483
484	Likewise, to create a class hierarchy in which every initializer inherited by
485	a new object is invoked:
486
487	package Base;
488	sub new {
489	my ($class, %args) = @_;
490	my $obj = bless {}, $class;
491	$obj->EVERY::LAST::Init(\%args);
492	}
493
494	package Derived1;
495	use base 'Base';
496	sub Init {
497	my ($argsref) = @_;
498	...
499	}
500
501	package Derived2;
502	use base 'Base', 'Derived1';
503	sub Init {
504	my ($argsref) = @_;
505	...
506	}
507
508	et cetera. Every derived class than needs some additional initialization
509	behaviour simply adds its own C<Init> method (I<not> a C<new> method),
510	which the call to C<EVERY::LAST::Init> in the inherited constructor
511	then correctly picks up.
512
513
e4783b1c JH	514	=head1 AUTHOR
	515
	516	Damian Conway (damian@conway.org)
	517
	518	=head1 BUGS AND IRRITATIONS
	519
	520	Because it's a module, not an integral part of the interpreter, NEXT.pm
	521	has to guess where the surrounding call was found in the method
	522	look-up sequence. In the presence of diamond inheritance patterns
	523	it occasionally guesses wrong.
	524
	525	It's also too slow (despite caching).
	526
	527	Comment, suggestions, and patches welcome.
	528
	529	=head1 COPYRIGHT
	530
55a1c97c	531	Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
e4783b1c	532	This module is free software. It may be used, redistributed
55a1c97c	533	and/or modified under the same terms as Perl itself.