7 sub NEXT::ELSEWHERE::ancestors
11 while (my $next = shift @inlist) {
14 unshift @inlist, @{"$outlist[-1]::ISA"};
19 sub NEXT::ELSEWHERE::ordered_ancestors
23 while (my $next = shift @inlist) {
26 push @inlist, @{"$outlist[-1]::ISA"};
28 return sort { $a->isa($b) ? -1
37 until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
38 my $caller = (caller($depth))[3];
39 my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
40 undef $NEXT::AUTOLOAD;
41 my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
42 my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
43 croak "Can't call $wanted from $caller"
44 unless $caller_method eq $wanted_method;
46 my $key = ref $self && overload::Overloaded($self)
47 ? overload::StrVal($self) : $self;
49 local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
50 ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
52 unless ($NEXT::NEXT{$key,$wanted_method}) {
54 NEXT::ELSEWHERE::ancestors ref $self || $self,
57 last if shift @forebears eq $caller_class
60 @{$NEXT::NEXT{$key,$wanted_method}} =
61 map { *{"${_}::$caller_method"}{CODE}||() } @forebears
62 unless $wanted_method eq 'AUTOLOAD';
63 @{$NEXT::NEXT{$key,$wanted_method}} =
64 map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
65 unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
66 $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
68 my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
69 while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
70 && defined $call_method
71 && $NEXT::SEEN->{$key,$call_method}++) {
72 $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
74 unless (defined $call_method) {
75 return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
76 (local $Carp::CarpLevel)++;
77 croak qq(Can't locate object method "$wanted_method" ),
78 qq(via package "$caller_class");
80 return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
82 ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
83 if $wanted_method eq 'AUTOLOAD';
84 $$call_method = $caller_class."::NEXT::".$wanted_method;
85 return $call_method->(@_);
89 package NEXT::UNSEEN; @ISA = 'NEXT';
90 package NEXT::DISTINCT; @ISA = 'NEXT';
91 package NEXT::ACTUAL; @ISA = 'NEXT';
92 package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
93 package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
94 package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
95 package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
97 package EVERY::LAST; @ISA = 'EVERY';
98 package EVERY; @ISA = 'NEXT';
103 until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
104 my $caller = (caller($depth))[3];
105 my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD';
106 undef $EVERY::AUTOLOAD;
107 my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
109 my $key = ref($self) && overload::Overloaded($self)
110 ? overload::StrVal($self) : $self;
112 local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
113 $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
115 return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
117 my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
119 @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
122 my @every = map { my $sub = "${_}::$wanted_method";
123 !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
125 unless $wanted_method eq 'AUTOLOAD';
127 my $want = wantarray;
130 return map {($_, [$self->$_(@_[1..$#_])])} @every;
132 elsif (defined $want) {
133 return { map {($_, scalar($self->$_(@_[1..$#_])))}
138 $self->$_(@_[1..$#_]) for @every;
143 @every = map { my $sub = "${_}::AUTOLOAD";
144 !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
147 return map { $$_ = ref($self)."::EVERY::".$wanted_method;
148 ($_, [$self->$_(@_[1..$#_])]);
151 elsif (defined $want) {
152 return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
153 ($_, scalar($self->$_(@_[1..$#_])))
159 $$_ = ref($self)."::EVERY::".$wanted_method;
160 $self->$_(@_[1..$#_]);
173 NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
181 sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
182 sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
186 sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
187 sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
190 sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
191 sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
192 sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
196 sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
197 sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
198 sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
202 my $obj = bless {}, "D";
204 $obj->method(); # Calls D::method, A::method, C::method
205 $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
207 # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
213 NEXT.pm adds a pseudoclass named C<NEXT> to any program
214 that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
215 C<m> is redispatched as if the calling method had not originally been found.
217 In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
218 left-to-right search of C<$self>'s class hierarchy that resulted in the
219 original call to C<m>.
221 Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
222 begins a new dispatch that is restricted to searching the ancestors
223 of the current class. C<$self-E<gt>NEXT::m()> can backtrack
224 past the current class -- to look for a suitable method in other
225 ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
227 A typical use would be in the destructors of a class hierarchy,
228 as illustrated in the synopsis above. Each class in the hierarchy
229 has a DESTROY method that performs some class-specific action
230 and then redispatches the call up the hierarchy. As a result,
231 when an object of class D is destroyed, the destructors of I<all>
232 its parent classes are called (in depth-first, left-to-right order).
234 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
235 If such a method determined that it was not able to handle a
236 particular call, it might choose to redispatch that call, in the
237 hope that some other C<AUTOLOAD> (above it, or to its left) might
240 By default, if a redispatch attempt fails to find another method
241 elsewhere in the objects class hierarchy, it quietly gives up and does
242 nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
243 is also unlike the (generally annoying) behaviour of C<SUPER>, which
244 throws an exception if it cannot redispatch.
246 Note that it is a fatal error for any method (including C<AUTOLOAD>)
247 to attempt to redispatch any method that does not have the
248 same name. For example:
250 sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
253 =head2 Enforcing redispatch
255 It is possible to make C<NEXT> redispatch more demandingly (i.e. like
256 C<SUPER> does), so that the redispatch throws an exception if it cannot
257 find a "next" method to call.
259 To do this, simple invoke the redispatch as:
261 $self->NEXT::ACTUAL::method();
265 $self->NEXT::method();
267 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
268 or it should throw an exception.
270 C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
271 decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
275 if ($AUTOLOAD =~ /foo|bar/) {
278 else { # try elsewhere
279 shift()->NEXT::ACTUAL::AUTOLOAD(@_);
283 By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
284 method call, an exception will be thrown (as usually happens in the absence of
285 a suitable C<AUTOLOAD>).
288 =head2 Avoiding repetitions
290 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
301 sub foo { print "called A::foo\n"; shift->NEXT::foo() }
304 sub foo { print "called B::foo\n"; shift->NEXT::foo() }
306 package C; @ISA = qw( A );
307 sub foo { print "called C::foo\n"; shift->NEXT::foo() }
309 package D; @ISA = qw(A B);
310 sub foo { print "called D::foo\n"; shift->NEXT::foo() }
312 package E; @ISA = qw(C D);
313 sub foo { print "called E::foo\n"; shift->NEXT::foo() }
317 then derived classes may (re-)inherit base-class methods through two or
318 more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
319 through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
320 will invoke the multiply inherited method as many times as it is
321 inherited. For example, the above code prints:
330 (i.e. C<A::foo> is called twice).
332 In some cases this I<may> be the desired effect within a diamond hierarchy,
333 but in others (e.g. for destructors) it may be more appropriate to
334 call each method only once during a sequence of redispatches.
336 To cover such cases, you can redispatch methods via:
338 $self->NEXT::DISTINCT::method();
342 $self->NEXT::method();
344 This causes the redispatcher to only visit each distinct C<method> method
345 once. That is, to skip any classes in the hierarchy that it has
346 already visited during redispatch. So, for example, if the
347 previous example were rewritten:
350 sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
353 sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
355 package C; @ISA = qw( A );
356 sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
358 package D; @ISA = qw(A B);
359 sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
361 package E; @ISA = qw(C D);
362 sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
374 and omit the second call to C<A::foo> (since it would not be distinct
375 from the first call to C<A::foo>).
377 Note that you can also use:
379 $self->NEXT::DISTINCT::ACTUAL::method();
383 $self->NEXT::ACTUAL::DISTINCT::method();
385 to get both unique invocation I<and> exception-on-failure.
387 Note that, for historical compatibility, you can also use
388 C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
391 =head2 Invoking all versions of a method with a single call
393 Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
394 Its behaviour is considerably simpler than that of the C<NEXT> family.
399 calls I<every> method named C<foo> that the object in C<$obj> has inherited.
404 package A; @ISA = qw(B D X);
405 sub foo { print "A::foo " }
407 package B; @ISA = qw(D X);
408 sub foo { print "B::foo " }
410 package X; @ISA = qw(D);
411 sub foo { print "X::foo " }
414 sub foo { print "D::foo " }
418 my $obj = bless {}, 'A';
419 $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
421 Prefixing a method call with C<EVERY::> causes every method in the
422 object's hierarchy with that name to be invoked. As the above example
423 illustrates, they are not called in Perl's usual "left-most-depth-first"
424 order. Instead, they are called "breadth-first-dependency-wise".
426 That means that the inheritance tree of the object is traversed breadth-first
427 and the resulting order of classes is used as the sequence in which methods
428 are called. However, that sequence is modified by imposing a rule that the
429 appropriate method of a derived class must be called before the same method of
430 any ancestral class. That's why, in the above example, C<X::foo> is called
431 before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
433 In general, there's no need to worry about the order of calls. They will be
434 left-to-right, breadth-first, most-derived-first. This works perfectly for
435 most inherited methods (including destructors), but is inappropriate for
436 some kinds of methods (such as constructors, cloners, debuggers, and
437 initializers) where it's more appropriate that the least-derived methods be
438 called first (as more-derived methods may rely on the behaviour of their
439 "ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
441 $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
443 you can use the C<EVERY::LAST> pseudo-class:
445 $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
447 which reverses the order of method call.
449 Whichever version is used, the actual methods are called in the same
450 context (list, scalar, or void) as the original call via C<EVERY>, and return:
456 A hash of array references in list context. Each entry of the hash has the
457 fully qualified method name as its key and a reference to an array containing
458 the method's list-context return values as its value.
462 A reference to a hash of scalar values in scalar context. Each entry of the hash has the
463 fully qualified method name as its key and the method's scalar-context return values as its value.
467 Nothing in void context (obviously).
471 =head2 Using C<EVERY> methods
473 The typical way to use an C<EVERY> call is to wrap it in another base
474 method, that all classes inherit. For example, to ensure that every
475 destructor an object inherits is actually called (as opposed to just the
476 left-most-depth-first-est one):
479 sub DESTROY { $_[0]->EVERY::Destroy }
486 use base 'Base', 'Derived1';
489 et cetera. Every derived class than needs its own clean-up
490 behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
491 which the call to C<EVERY::LAST::Destroy> in the inherited destructor
492 then correctly picks up.
494 Likewise, to create a class hierarchy in which every initializer inherited by
495 a new object is invoked:
499 my ($class, %args) = @_;
500 my $obj = bless {}, $class;
501 $obj->EVERY::LAST::Init(\%args);
512 use base 'Base', 'Derived1';
518 et cetera. Every derived class than needs some additional initialization
519 behaviour simply adds its own C<Init> method (I<not> a C<new> method),
520 which the call to C<EVERY::LAST::Init> in the inherited constructor
521 then correctly picks up.
526 Damian Conway (damian@conway.org)
528 =head1 BUGS AND IRRITATIONS
530 Because it's a module, not an integral part of the interpreter, NEXT.pm
531 has to guess where the surrounding call was found in the method
532 look-up sequence. In the presence of diamond inheritance patterns
533 it occasionally guesses wrong.
535 It's also too slow (despite caching).
537 Comment, suggestions, and patches welcome.
541 Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
542 This module is free software. It may be used, redistributed
543 and/or modified under the same terms as Perl itself.