[p5sagit/p5-mst-13.2.git] / lib / NEXT.pm

package NEXT;
$VERSION = '0.60_01';
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 $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;

	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 $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;

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