[perl5.git] / lib / NEXT.pm

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