perl/lib/NEXT.pm

package NEXT;
$VERSION = '0.60';
use Carp;
use strict;

sub NEXT::ELSEWHERE::ancestors
{
        my @inlist = shift;
        my @outlist = ();
        while (my $next = shift @inlist) {
                push @outlist, $next;
                no strict 'refs';
                unshift @inlist, @{"$outlist[-1]::ISA"};
        }
        return @outlist;
}

sub NEXT::ELSEWHERE::ordered_ancestors
{
        my @inlist = shift;
        my @outlist = ();
        while (my $next = shift @inlist) {
                push @outlist, $next;
                no strict 'refs';
                push @inlist, @{"$outlist[-1]::ISA"};
        }
        return sort { $a->isa($b) ? -1
                    : $b->isa($a) ? +1
                    :                0 } @outlist;
}

sub AUTOLOAD
{
        my ($self) = @_;
        my $caller = (caller(1))[3]; 
        my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
        undef $NEXT::AUTOLOAD;
        my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
        my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
        croak "Can't call $wanted from $caller"
                unless $caller_method eq $wanted_method;

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


        unless ($NEXT::NEXT{$self,$wanted_method}) {
                my @forebears =
                        NEXT::ELSEWHERE::ancestors ref $self || $self,
                                                   $wanted_class;
                while (@forebears) {
                        last if shift @forebears eq $caller_class
                }
                no strict 'refs';
                @{$NEXT::NEXT{$self,$wanted_method}} = 
                        map { *{"${_}::$caller_method"}{CODE}||() } @forebears
                                unless $wanted_method eq 'AUTOLOAD';
                @{$NEXT::NEXT{$self,$wanted_method}} = 
                        map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
                                unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
                $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
        }
        my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
        while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
               && defined $call_method
               && $NEXT::SEEN->{$self,$call_method}++) {
                $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
        }
        unless (defined $call_method) {
                return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
                (local $Carp::CarpLevel)++;
                croak qq(Can't locate object method "$wanted_method" ),
                      qq(via package "$caller_class");
        };
        return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
        no strict 'refs';
        ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
                if $wanted_method eq 'AUTOLOAD';
        $$call_method = $caller_class."::NEXT::".$wanted_method;
        return $call_method->(@_);
}

no strict 'vars';
package NEXT::UNSEEN;           @ISA = 'NEXT';
package NEXT::DISTINCT;         @ISA = 'NEXT';
package NEXT::ACTUAL;           @ISA = 'NEXT';
package NEXT::ACTUAL::UNSEEN;   @ISA = 'NEXT';
package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
package NEXT::UNSEEN::ACTUAL;   @ISA = 'NEXT';
package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';

package EVERY::LAST;            @ISA = 'EVERY';
package EVERY;                  @ISA = 'NEXT';
sub AUTOLOAD
{
        my ($self) = @_;
        my $caller = (caller(1))[3]; 
        my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD';
        undef $EVERY::AUTOLOAD;
        my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;

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

        return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++;
        
        my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
                                                           $wanted_class;
        @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
        no strict 'refs';
        my %seen;
        my @every = map { my $sub = "${_}::$wanted_method";
                          !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
                        } @forebears
                                unless $wanted_method eq 'AUTOLOAD';

        my $want = wantarray;
        if (@every) {
                if ($want) {
                        return map {($_, [$self->$_(@_[1..$#_])])} @every;
                }
                elsif (defined $want) {
                        return { map {($_, scalar($self->$_(@_[1..$#_])))}
                                     @every
                               };
                }
                else {
                        $self->$_(@_[1..$#_]) for @every;
                        return;
                }
        }

        @every = map { my $sub = "${_}::AUTOLOAD";
                       !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
                     } @forebears;
        if ($want) {
                return map { $$_ = ref($self)."::EVERY::".$wanted_method;
                             ($_, [$self->$_(@_[1..$#_])]);
                           } @every;
        }
        elsif (defined $want) {
                return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
                               ($_, scalar($self->$_(@_[1..$#_])))
                             } @every
                       };
        }
        else {
                for (@every) {
                        $$_ = ref($self)."::EVERY::".$wanted_method;
                        $self->$_(@_[1..$#_]);
                }
                return;
        }
}


1;

__END__

=head1 NAME

NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch


=head1 SYNOPSIS

    use NEXT;

    package A;
    sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
    sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }

    package B;
    use base qw( A );
    sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }

    package C;
    sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
    sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }

    package D;
    use base qw( B C );
    sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
    sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
    sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }

    package main;

    my $obj = bless {}, "D";

    $obj->method();             # Calls D::method, A::method, C::method
    $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD

    # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY


=head1 DESCRIPTION

NEXT.pm adds a pseudoclass named C<NEXT> to any program
that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
C<m> is redispatched as if the calling method had not originally been found.

In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
left-to-right search of C<$self>'s class hierarchy that resulted in the
original call to C<m>.

Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
begins a new dispatch that is restricted to searching the ancestors
of the current class. C<$self-E<gt>NEXT::m()> can backtrack
past the current class -- to look for a suitable method in other
ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.

A typical use would be in the destructors of a class hierarchy,
as illustrated in the synopsis above. Each class in the hierarchy
has a DESTROY method that performs some class-specific action
and then redispatches the call up the hierarchy. As a result,
when an object of class D is destroyed, the destructors of I<all>
its parent classes are called (in depth-first, left-to-right order).

Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
If such a method determined that it was not able to handle a
particular call, it might choose to redispatch that call, in the
hope that some other C<AUTOLOAD> (above it, or to its left) might
do better.

By default, if a redispatch attempt fails to find another method
elsewhere in the objects class hierarchy, it quietly gives up and does
nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
is also unlike the (generally annoying) behaviour of C<SUPER>, which
throws an exception if it cannot redispatch.

Note that it is a fatal error for any method (including C<AUTOLOAD>)
to attempt to redispatch any method that does not have the
same name. For example:

        sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }


=head2 Enforcing redispatch

It is possible to make C<NEXT> redispatch more demandingly (i.e. like
C<SUPER> does), so that the redispatch throws an exception if it cannot
find a "next" method to call.

To do this, simple invoke the redispatch as:

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

rather than:

        $self->NEXT::method();

The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
or it should throw an exception.

C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure 
semantics:

        sub AUTOLOAD {
                if ($AUTOLOAD =~ /foo|bar/) {
                        # handle here
                }
                else {  # try elsewhere
                        shift()->NEXT::ACTUAL::AUTOLOAD(@_);
                }
        }

By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
method call, an exception will be thrown (as usually happens in the absence of
a suitable C<AUTOLOAD>).


=head2 Avoiding repetitions

If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:

        #     A   B
        #    / \ /
        #   C   D
        #    \ /
        #     E

        use NEXT;

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

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

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

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

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

        E->foo();

then derived classes may (re-)inherit base-class methods through two or
more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
will invoke the multiply inherited method as many times as it is
inherited. For example, the above code prints:

        called E::foo
        called C::foo
        called A::foo
        called D::foo
        called A::foo
        called B::foo

(i.e. C<A::foo> is called twice).

In some cases this I<may> be the desired effect within a diamond hierarchy,
but in others (e.g. for destructors) it may be more appropriate to 
call each method only once during a sequence of redispatches.

To cover such cases, you can redispatch methods via:

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

rather than:

        $self->NEXT::method();

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

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

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

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

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

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

        E->foo();

then it would print:
        
        called E::foo
        called C::foo
        called A::foo
        called D::foo
        called B::foo

and omit the second call to C<A::foo> (since it would not be distinct
from the first call to C<A::foo>).

Note that you can also use:

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

or:

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

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

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


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

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

        $obj->EVERY::foo();

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

        use NEXT;

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

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

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

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

        package main;

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

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

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

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

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

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

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

which reverses the order of method call.

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

=over

=item *

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

=item *

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

=item *

Nothing in void context (obviously).

=back

=head2 Using C<EVERY> methods

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

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

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

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

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

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

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

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

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

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


=head1 AUTHOR

Damian Conway (damian@conway.org)

=head1 BUGS AND IRRITATIONS

Because it's a module, not an integral part of the interpreter, NEXT.pm
has to guess where the surrounding call was found in the method
look-up sequence. In the presence of diamond inheritance patterns
it occasionally guesses wrong.

It's also too slow (despite caching).

Comment, suggestions, and patches welcome.

=head1 COPYRIGHT

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