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) = $caller =~ m{(.*)::(.*)}g;
46 my ($wanted_class, $wanted_method) = $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}} =
65 map { *{"${_}::$caller_method"}{CODE}||() } @forebears
66 unless $wanted_method eq 'AUTOLOAD';
67 @{$NEXT::NEXT{$key,$wanted_method}} =
68 map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
69 unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
70 $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
72 my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
73 while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
74 && defined $call_method
75 && $NEXT::SEEN->{$key,$call_method}++) {
76 $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
78 unless (defined $call_method) {
79 return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
80 (local $Carp::CarpLevel)++;
81 croak qq(Can't locate object method "$wanted_method" ),
82 qq(via package "$caller_class");
84 return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
86 ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
87 if $wanted_method eq 'AUTOLOAD';
88 $$call_method = $caller_class."::NEXT::".$wanted_method;
89 return $call_method->(@_);
94 package NEXT; NEXT::ELSEWHERE::buildAUTOLOAD();
95 package NEXT::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
96 package NEXT::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
97 package NEXT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
98 package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
99 package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
100 package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
101 package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
105 sub EVERY::ELSEWHERE::buildAUTOLOAD {
106 my $autoload_name = caller() . '::AUTOLOAD';
109 *{$autoload_name} = sub {
112 until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
113 my $caller = (caller($depth))[3];
114 my $wanted = $EVERY::AUTOLOAD || $autoload_name;
115 undef $EVERY::AUTOLOAD;
116 my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
118 my $key = ref($self) && overload::Overloaded($self)
119 ? overload::StrVal($self) : $self;
121 local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
122 $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
124 return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
126 my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
128 @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
131 my @every = map { my $sub = "${_}::$wanted_method";
132 !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
134 unless $wanted_method eq 'AUTOLOAD';
136 my $want = wantarray;
139 return map {($_, [$self->$_(@_[1..$#_])])} @every;
141 elsif (defined $want) {
142 return { map {($_, scalar($self->$_(@_[1..$#_])))}
147 $self->$_(@_[1..$#_]) for @every;
152 @every = map { my $sub = "${_}::AUTOLOAD";
153 !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
156 return map { $$_ = ref($self)."::EVERY::".$wanted_method;
157 ($_, [$self->$_(@_[1..$#_])]);
160 elsif (defined $want) {
161 return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
162 ($_, scalar($self->$_(@_[1..$#_])))
168 $$_ = ref($self)."::EVERY::".$wanted_method;
169 $self->$_(@_[1..$#_]);
176 package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD();
177 package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD();
185 NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
193 sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
194 sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
198 sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
199 sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
202 sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
203 sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
204 sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
208 sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
209 sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
210 sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
214 my $obj = bless {}, "D";
216 $obj->method(); # Calls D::method, A::method, C::method
217 $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
219 # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
225 NEXT.pm adds a pseudoclass named C<NEXT> to any program
226 that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
227 C<m> is redispatched as if the calling method had not originally been found.
229 In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
230 left-to-right search of C<$self>'s class hierarchy that resulted in the
231 original call to C<m>.
233 Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
234 begins a new dispatch that is restricted to searching the ancestors
235 of the current class. C<$self-E<gt>NEXT::m()> can backtrack
236 past the current class -- to look for a suitable method in other
237 ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
239 A typical use would be in the destructors of a class hierarchy,
240 as illustrated in the synopsis above. Each class in the hierarchy
241 has a DESTROY method that performs some class-specific action
242 and then redispatches the call up the hierarchy. As a result,
243 when an object of class D is destroyed, the destructors of I<all>
244 its parent classes are called (in depth-first, left-to-right order).
246 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
247 If such a method determined that it was not able to handle a
248 particular call, it might choose to redispatch that call, in the
249 hope that some other C<AUTOLOAD> (above it, or to its left) might
252 By default, if a redispatch attempt fails to find another method
253 elsewhere in the objects class hierarchy, it quietly gives up and does
254 nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
255 is also unlike the (generally annoying) behaviour of C<SUPER>, which
256 throws an exception if it cannot redispatch.
258 Note that it is a fatal error for any method (including C<AUTOLOAD>)
259 to attempt to redispatch any method that does not have the
260 same name. For example:
262 sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
265 =head2 Enforcing redispatch
267 It is possible to make C<NEXT> redispatch more demandingly (i.e. like
268 C<SUPER> does), so that the redispatch throws an exception if it cannot
269 find a "next" method to call.
271 To do this, simple invoke the redispatch as:
273 $self->NEXT::ACTUAL::method();
277 $self->NEXT::method();
279 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
280 or it should throw an exception.
282 C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
283 decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
287 if ($AUTOLOAD =~ /foo|bar/) {
290 else { # try elsewhere
291 shift()->NEXT::ACTUAL::AUTOLOAD(@_);
295 By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
296 method call, an exception will be thrown (as usually happens in the absence of
297 a suitable C<AUTOLOAD>).
300 =head2 Avoiding repetitions
302 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
313 sub foo { print "called A::foo\n"; shift->NEXT::foo() }
316 sub foo { print "called B::foo\n"; shift->NEXT::foo() }
318 package C; @ISA = qw( A );
319 sub foo { print "called C::foo\n"; shift->NEXT::foo() }
321 package D; @ISA = qw(A B);
322 sub foo { print "called D::foo\n"; shift->NEXT::foo() }
324 package E; @ISA = qw(C D);
325 sub foo { print "called E::foo\n"; shift->NEXT::foo() }
329 then derived classes may (re-)inherit base-class methods through two or
330 more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
331 through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
332 will invoke the multiply inherited method as many times as it is
333 inherited. For example, the above code prints:
342 (i.e. C<A::foo> is called twice).
344 In some cases this I<may> be the desired effect within a diamond hierarchy,
345 but in others (e.g. for destructors) it may be more appropriate to
346 call each method only once during a sequence of redispatches.
348 To cover such cases, you can redispatch methods via:
350 $self->NEXT::DISTINCT::method();
354 $self->NEXT::method();
356 This causes the redispatcher to only visit each distinct C<method> method
357 once. That is, to skip any classes in the hierarchy that it has
358 already visited during redispatch. So, for example, if the
359 previous example were rewritten:
362 sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
365 sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
367 package C; @ISA = qw( A );
368 sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
370 package D; @ISA = qw(A B);
371 sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
373 package E; @ISA = qw(C D);
374 sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
386 and omit the second call to C<A::foo> (since it would not be distinct
387 from the first call to C<A::foo>).
389 Note that you can also use:
391 $self->NEXT::DISTINCT::ACTUAL::method();
395 $self->NEXT::ACTUAL::DISTINCT::method();
397 to get both unique invocation I<and> exception-on-failure.
399 Note that, for historical compatibility, you can also use
400 C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
403 =head2 Invoking all versions of a method with a single call
405 Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
406 Its behaviour is considerably simpler than that of the C<NEXT> family.
411 calls I<every> method named C<foo> that the object in C<$obj> has inherited.
416 package A; @ISA = qw(B D X);
417 sub foo { print "A::foo " }
419 package B; @ISA = qw(D X);
420 sub foo { print "B::foo " }
422 package X; @ISA = qw(D);
423 sub foo { print "X::foo " }
426 sub foo { print "D::foo " }
430 my $obj = bless {}, 'A';
431 $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
433 Prefixing a method call with C<EVERY::> causes every method in the
434 object's hierarchy with that name to be invoked. As the above example
435 illustrates, they are not called in Perl's usual "left-most-depth-first"
436 order. Instead, they are called "breadth-first-dependency-wise".
438 That means that the inheritance tree of the object is traversed breadth-first
439 and the resulting order of classes is used as the sequence in which methods
440 are called. However, that sequence is modified by imposing a rule that the
441 appropriate method of a derived class must be called before the same method of
442 any ancestral class. That's why, in the above example, C<X::foo> is called
443 before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
445 In general, there's no need to worry about the order of calls. They will be
446 left-to-right, breadth-first, most-derived-first. This works perfectly for
447 most inherited methods (including destructors), but is inappropriate for
448 some kinds of methods (such as constructors, cloners, debuggers, and
449 initializers) where it's more appropriate that the least-derived methods be
450 called first (as more-derived methods may rely on the behaviour of their
451 "ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
453 $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
455 you can use the C<EVERY::LAST> pseudo-class:
457 $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
459 which reverses the order of method call.
461 Whichever version is used, the actual methods are called in the same
462 context (list, scalar, or void) as the original call via C<EVERY>, and return:
468 A hash of array references in list context. Each entry of the hash has the
469 fully qualified method name as its key and a reference to an array containing
470 the method's list-context return values as its value.
474 A reference to a hash of scalar values in scalar context. Each entry of the hash has the
475 fully qualified method name as its key and the method's scalar-context return values as its value.
479 Nothing in void context (obviously).
483 =head2 Using C<EVERY> methods
485 The typical way to use an C<EVERY> call is to wrap it in another base
486 method, that all classes inherit. For example, to ensure that every
487 destructor an object inherits is actually called (as opposed to just the
488 left-most-depth-first-est one):
491 sub DESTROY { $_[0]->EVERY::Destroy }
498 use base 'Base', 'Derived1';
501 et cetera. Every derived class than needs its own clean-up
502 behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
503 which the call to C<EVERY::LAST::Destroy> in the inherited destructor
504 then correctly picks up.
506 Likewise, to create a class hierarchy in which every initializer inherited by
507 a new object is invoked:
511 my ($class, %args) = @_;
512 my $obj = bless {}, $class;
513 $obj->EVERY::LAST::Init(\%args);
524 use base 'Base', 'Derived1';
530 et cetera. Every derived class than needs some additional initialization
531 behaviour simply adds its own C<Init> method (I<not> a C<new> method),
532 which the call to C<EVERY::LAST::Init> in the inherited constructor
533 then correctly picks up.
538 Damian Conway (damian@conway.org)
540 =head1 BUGS AND IRRITATIONS
542 Because it's a module, not an integral part of the interpreter, NEXT.pm
543 has to guess where the surrounding call was found in the method
544 look-up sequence. In the presence of diamond inheritance patterns
545 it occasionally guesses wrong.
547 It's also too slow (despite caching).
549 Comment, suggestions, and patches welcome.
553 Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
554 This module is free software. It may be used, redistributed
555 and/or modified under the same terms as Perl itself.