[perl5.git] / lib / NEXT.pm

package NEXT;
$VERSION = '0.60_03';
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 NEXT::ELSEWHERE::buildAUTOLOAD
{
    my $autoload_name = caller() . '::AUTOLOAD';

    no strict 'refs';
    *{$autoload_name} = sub {
        my ($self) = @_;
        my $depth = 1;
        until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
        my $caller = (caller($depth))[3];
        my $wanted = $NEXT::AUTOLOAD || $autoload_name;
        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;                                  NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::UNSEEN;		@ISA = 'NEXT';     NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::DISTINCT;		@ISA = 'NEXT';     NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::ACTUAL;		@ISA = 'NEXT';     NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::ACTUAL::UNSEEN;	@ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::ACTUAL::DISTINCT;	@ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::UNSEEN::ACTUAL;	@ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
package NEXT::DISTINCT::ACTUAL;	@ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();

package EVERY;

sub EVERY::ELSEWHERE::buildAUTOLOAD {
    my $autoload_name = caller() . '::AUTOLOAD';

    no strict 'refs';
    *{$autoload_name} = sub {
        my ($self) = @_;
        my $depth = 1;
        until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
        my $caller = (caller($depth))[3];
        my $wanted = $EVERY::AUTOLOAD || $autoload_name;
        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;
        }
    };
}

package EVERY::LAST;   @ISA = 'EVERY';   EVERY::ELSEWHERE::buildAUTOLOAD();
package EVERY;         @ISA = 'NEXT';    EVERY::ELSEWHERE::buildAUTOLOAD();

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