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
33 sub NEXT::ELSEWHERE::buildAUTOLOAD
35 my $autoload_name = caller() . '::AUTOLOAD';
38 *{$autoload_name} = sub {
41 until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
42 my $caller = (caller($depth))[3];
43 my $wanted = $NEXT::AUTOLOAD || $autoload_name;
44 undef $NEXT::AUTOLOAD;
45 my ($caller_class, $caller_method) = do { $caller =~ m{(.*)::(.*)}g };
46 my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
47 croak "Can't call $wanted from $caller"
48 unless $caller_method eq $wanted_method;
50 my $key = ref $self && overload::Overloaded($self)
51 ? overload::StrVal($self) : $self;
53 local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
54 ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
56 unless ($NEXT::NEXT{$key,$wanted_method}) {
58 NEXT::ELSEWHERE::ancestors ref $self || $self,
61 last if shift @forebears eq $caller_class
64 @{$NEXT::NEXT{$key,$wanted_method}} =
66 my $stash = \%{"${_}::"};
67 ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE}))
68 ? *{$stash->{$caller_method}}{CODE}
70 unless $wanted_method eq 'AUTOLOAD';
71 @{$NEXT::NEXT{$key,$wanted_method}} =
73 my $stash = \%{"${_}::"};
74 ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE}))
77 unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
78 $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
80 my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
81 while (do { $wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ }
82 && defined $call_method
83 && $NEXT::SEEN->{$key,$call_method}++) {
84 $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
86 unless (defined $call_method) {
87 return unless do { $wanted_class =~ /^NEXT:.*:ACTUAL/ };
88 (local $Carp::CarpLevel)++;
89 croak qq(Can't locate object method "$wanted_method" ),
90 qq(via package "$caller_class");
92 return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
94 do { ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// }
95 if $wanted_method eq 'AUTOLOAD';
96 $$call_method = $caller_class."::NEXT::".$wanted_method;
97 return $call_method->(@_);
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();
113 sub EVERY::ELSEWHERE::buildAUTOLOAD {
114 my $autoload_name = caller() . '::AUTOLOAD';
117 *{$autoload_name} = sub {
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;
124 my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
126 my $key = ref($self) && overload::Overloaded($self)
127 ? overload::StrVal($self) : $self;
129 local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
130 $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
132 return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
134 my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
136 @forebears = reverse @forebears if do { $wanted_class =~ /\bLAST\b/ };
139 my @every = map { my $sub = "${_}::$wanted_method";
140 !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
142 unless $wanted_method eq 'AUTOLOAD';
144 my $want = wantarray;
147 return map {($_, [$self->$_(@_[1..$#_])])} @every;
149 elsif (defined $want) {
150 return { map {($_, scalar($self->$_(@_[1..$#_])))}
155 $self->$_(@_[1..$#_]) for @every;
160 @every = map { my $sub = "${_}::AUTOLOAD";
161 !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
164 return map { $$_ = ref($self)."::EVERY::".$wanted_method;
165 ($_, [$self->$_(@_[1..$#_])]);
168 elsif (defined $want) {
169 return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
170 ($_, scalar($self->$_(@_[1..$#_])))
176 $$_ = ref($self)."::EVERY::".$wanted_method;
177 $self->$_(@_[1..$#_]);
184 package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD();
185 package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD();
193 NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
201 sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
202 sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
206 sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
207 sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
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() }
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() }
222 my $obj = bless {}, "D";
224 $obj->method(); # Calls D::method, A::method, C::method
225 $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
227 # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
233 NEXT.pm adds a pseudoclass named C<NEXT> to any program
234 that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
235 C<m> is redispatched as if the calling method had not originally been found.
237 In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
238 left-to-right search of C<$self>'s class hierarchy that resulted in the
239 original call to C<m>.
241 Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
242 begins a new dispatch that is restricted to searching the ancestors
243 of the current class. C<$self-E<gt>NEXT::m()> can backtrack
244 past the current class -- to look for a suitable method in other
245 ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
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).
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
260 By default, if a redispatch attempt fails to find another method
261 elsewhere in the objects class hierarchy, it quietly gives up and does
262 nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
263 is also unlike the (generally annoying) behaviour of C<SUPER>, which
264 throws an exception if it cannot redispatch.
266 Note that it is a fatal error for any method (including C<AUTOLOAD>)
267 to attempt to redispatch any method that does not have the
268 same name. For example:
270 sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
273 =head2 Enforcing redispatch
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.
279 To do this, simple invoke the redispatch as:
281 $self->NEXT::ACTUAL::method();
285 $self->NEXT::method();
287 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
288 or it should throw an exception.
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
295 if ($AUTOLOAD =~ /foo|bar/) {
298 else { # try elsewhere
299 shift()->NEXT::ACTUAL::AUTOLOAD(@_);
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>).
308 =head2 Avoiding repetitions
310 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
321 sub foo { print "called A::foo\n"; shift->NEXT::foo() }
324 sub foo { print "called B::foo\n"; shift->NEXT::foo() }
326 package C; @ISA = qw( A );
327 sub foo { print "called C::foo\n"; shift->NEXT::foo() }
329 package D; @ISA = qw(A B);
330 sub foo { print "called D::foo\n"; shift->NEXT::foo() }
332 package E; @ISA = qw(C D);
333 sub foo { print "called E::foo\n"; shift->NEXT::foo() }
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:
350 (i.e. C<A::foo> is called twice).
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.
356 To cover such cases, you can redispatch methods via:
358 $self->NEXT::DISTINCT::method();
362 $self->NEXT::method();
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
367 previous example were rewritten:
370 sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
373 sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
375 package C; @ISA = qw( A );
376 sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
378 package D; @ISA = qw(A B);
379 sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
381 package E; @ISA = qw(C D);
382 sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
394 and omit the second call to C<A::foo> (since it would not be distinct
395 from the first call to C<A::foo>).
397 Note that you can also use:
399 $self->NEXT::DISTINCT::ACTUAL::method();
403 $self->NEXT::ACTUAL::DISTINCT::method();
405 to get both unique invocation I<and> exception-on-failure.
407 Note that, for historical compatibility, you can also use
408 C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
411 =head2 Invoking all versions of a method with a single call
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.
419 calls I<every> method named C<foo> that the object in C<$obj> has inherited.
424 package A; @ISA = qw(B D X);
425 sub foo { print "A::foo " }
427 package B; @ISA = qw(D X);
428 sub foo { print "B::foo " }
430 package X; @ISA = qw(D);
431 sub foo { print "X::foo " }
434 sub foo { print "D::foo " }
438 my $obj = bless {}, 'A';
439 $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
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".
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
449 appropriate method of a derived class must be called before the same method of
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>.
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:
461 $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
463 you can use the C<EVERY::LAST> pseudo-class:
465 $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
467 which reverses the order of method call.
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:
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.
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.
487 Nothing in void context (obviously).
491 =head2 Using C<EVERY> methods
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):
499 sub DESTROY { $_[0]->EVERY::Destroy }
506 use base 'Base', 'Derived1';
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.
514 Likewise, to create a class hierarchy in which every initializer inherited by
515 a new object is invoked:
519 my ($class, %args) = @_;
520 my $obj = bless {}, $class;
521 $obj->EVERY::LAST::Init(\%args);
532 use base 'Base', 'Derived1';
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.
546 Damian Conway (damian@conway.org)
548 =head1 BUGS AND IRRITATIONS
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.
555 It's also too slow (despite caching).
557 Comment, suggestions, and patches welcome.
561 Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
562 This module is free software. It may be used, redistributed
563 and/or modified under the same terms as Perl itself.