[perl5.git] / lib / NEXT.pm

package NEXT;
$VERSION = '0.60_02';
use Carp;
use strict;
use overload ();

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;

	my $key = ref $self && overload::Overloaded($self)
	    ? overload::StrVal($self) : $self;

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

	unless ($NEXT::NEXT{$key,$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{$key,$wanted_method}} = 
			map { *{"${_}::$caller_method"}{CODE}||() } @forebears
				unless $wanted_method eq 'AUTOLOAD';
		@{$NEXT::NEXT{$key,$wanted_method}} = 
			map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
				unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
		$NEXT::SEEN->{$key,*{$caller}{CODE}}++;
	}
	my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
	while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
	       && defined $call_method
	       && $NEXT::SEEN->{$key,$call_method}++) {
		$call_method = shift @{$NEXT::NEXT{$key,$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;

	my $key = ref($self) && overload::Overloaded($self)
	    ? overload::StrVal($self) : $self;

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

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