10 while (my $next = shift @inlist) {
13 unshift @inlist, @{"$outlist[-1]::ISA"};
21 my $caller = (caller(1))[3];
22 my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
23 undef $NEXT::AUTOLOAD;
24 my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
25 my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
26 croak "Can't call $wanted from $caller"
27 unless $caller_method eq $wanted_method;
29 local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
30 ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
33 unless ($NEXT::NEXT{$self,$wanted_method}) {
35 ancestors ref $self || $self, $wanted_class;
37 last if shift @forebears eq $caller_class
40 @{$NEXT::NEXT{$self,$wanted_method}} =
41 map { *{"${_}::$caller_method"}{CODE}||() } @forebears
42 unless $wanted_method eq 'AUTOLOAD';
43 @{$NEXT::NEXT{$self,$wanted_method}} =
44 map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
45 unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
47 my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
48 while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
49 && $NEXT::SEEN->{$self,$call_method}++) {
50 $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
52 unless (defined $call_method) {
53 return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
54 (local $Carp::CarpLevel)++;
55 croak qq(Can't locate object method "$wanted_method" ),
56 qq(via package "$caller_class");
58 return shift()->$call_method(@_) if ref $call_method eq 'CODE';
60 ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
61 if $wanted_method eq 'AUTOLOAD';
62 $$call_method = $caller_class."::NEXT::".$wanted_method;
63 return $call_method->(@_);
67 package NEXT::UNSEEN; @ISA = 'NEXT';
68 package NEXT::ACTUAL; @ISA = 'NEXT';
69 package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
70 package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
78 NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
86 sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
87 sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
91 sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
92 sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
95 sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
96 sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
97 sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
101 sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
102 sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
103 sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
107 my $obj = bless {}, "D";
109 $obj->method(); # Calls D::method, A::method, C::method
110 $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
112 # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
117 NEXT.pm adds a pseudoclass named C<NEXT> to any program
118 that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
119 C<m> is redispatched as if the calling method had not originally been found.
121 In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
122 left-to-right search of C<$self>'s class hierarchy that resulted in the
123 original call to C<m>.
125 Note that this is not the same thing as C<$self->SUPER::m()>, which
126 begins a new dispatch that is restricted to searching the ancestors
127 of the current class. C<$self->NEXT::m()> can backtrack
128 past the current class -- to look for a suitable method in other
129 ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot.
131 A typical use would be in the destructors of a class hierarchy,
132 as illustrated in the synopsis above. Each class in the hierarchy
133 has a DESTROY method that performs some class-specific action
134 and then redispatches the call up the hierarchy. As a result,
135 when an object of class D is destroyed, the destructors of I<all>
136 its parent classes are called (in depth-first, left-to-right order).
138 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
139 If such a method determined that it was not able to handle a
140 particular call, it might choose to redispatch that call, in the
141 hope that some other C<AUTOLOAD> (above it, or to its left) might
144 By default, if a redispatch attempt fails to find another method
145 elsewhere in the objects class hierarchy, it quietly gives up and does
146 nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
147 is also unlike the (generally annoying) behaviour of C<SUPER>, which
148 throws an exception if it cannot redispatch.
150 Note that it is a fatal error for any method (including C<AUTOLOAD>)
151 to attempt to redispatch any method that does not have the
152 same name. For example:
154 sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
157 =head2 Enforcing redispatch
159 It is possible to make C<NEXT> redispatch more demandingly (i.e. like
160 C<SUPER> does), so that the redispatch throws an exception if it cannot
161 find a "next" method to call.
163 To do this, simple invoke the redispatch as:
165 $self->NEXT::ACTUAL::method();
169 $self->NEXT::method();
171 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
172 or it should throw an exception.
174 C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
175 decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
179 if ($AUTOLOAD =~ /foo|bar/) {
182 else { # try elsewhere
183 shift()->NEXT::ACTUAL::AUTOLOAD(@_);
187 By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
188 method call, an exception will be thrown (as usually happens in the absence of
189 a suitable C<AUTOLOAD>).
192 =head2 Avoiding repetitions
194 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
205 sub foo { print "called A::foo\n"; shift->NEXT::foo() }
208 sub foo { print "called B::foo\n"; shift->NEXT::foo() }
210 package C; @ISA = qw( A );
211 sub foo { print "called C::foo\n"; shift->NEXT::foo() }
213 package D; @ISA = qw(A B);
214 sub foo { print "called D::foo\n"; shift->NEXT::foo() }
216 package E; @ISA = qw(C D);
217 sub foo { print "called E::foo\n"; shift->NEXT::foo() }
221 then derived classes may (re-)inherit base-class methods through two or
222 more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
223 through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
224 will invoke the multiply inherited method as many times as it is
225 inherited. For example, the above code prints:
234 (i.e. C<A::foo> is called twice).
236 In some cases this I<may> be the desired effect within a diamond hierarchy,
237 but in others (e.g. for destructors) it may be more appropriate to
238 call each method only once during a sequence of redispatches.
240 To cover such cases, you can redispatch methods via:
242 $self->NEXT::UNSEEN::method();
246 $self->NEXT::method();
248 This causes the redispatcher to skip any classes in the hierarchy that it has
249 already visited in an earlier redispatch. So, for example, if the
250 previous example were rewritten:
253 sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
256 sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
258 package C; @ISA = qw( A );
259 sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
261 package D; @ISA = qw(A B);
262 sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
264 package E; @ISA = qw(C D);
265 sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }
277 and omit the second call to C<A::foo>.
279 Note that you can also use:
281 $self->NEXT::UNSEEN::ACTUAL::method();
285 $self->NEXT::ACTUAL::UNSEEN::method();
287 to get both unique invocation I<and> exception-on-failure.
292 Damian Conway (damian@conway.org)
294 =head1 BUGS AND IRRITATIONS
296 Because it's a module, not an integral part of the interpreter, NEXT.pm
297 has to guess where the surrounding call was found in the method
298 look-up sequence. In the presence of diamond inheritance patterns
299 it occasionally guesses wrong.
301 It's also too slow (despite caching).
303 Comment, suggestions, and patches welcome.
307 Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
308 This module is free software. It may be used, redistributed
309 and/or modified under the same terms as Perl itself.