This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
57e2b410358207db2f42ba48844582987c1f2721
[perl5.git] / lib / NEXT.pm
1 package NEXT;
2 $VERSION = '0.60_02';
3 use Carp;
4 use strict;
5 use overload ();
6
7 sub NEXT::ELSEWHERE::ancestors
8 {
9         my @inlist = shift;
10         my @outlist = ();
11         while (my $next = shift @inlist) {
12                 push @outlist, $next;
13                 no strict 'refs';
14                 unshift @inlist, @{"$outlist[-1]::ISA"};
15         }
16         return @outlist;
17 }
18
19 sub NEXT::ELSEWHERE::ordered_ancestors
20 {
21         my @inlist = shift;
22         my @outlist = ();
23         while (my $next = shift @inlist) {
24                 push @outlist, $next;
25                 no strict 'refs';
26                 push @inlist, @{"$outlist[-1]::ISA"};
27         }
28         return sort { $a->isa($b) ? -1
29                     : $b->isa($a) ? +1
30                     :                0 } @outlist;
31 }
32
33 sub AUTOLOAD
34 {
35         my ($self) = @_;
36         my $depth = 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;
45
46         my $key = ref $self && overload::Overloaded($self)
47             ? overload::StrVal($self) : $self;
48
49         local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
50               ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
51
52         unless ($NEXT::NEXT{$key,$wanted_method}) {
53                 my @forebears =
54                         NEXT::ELSEWHERE::ancestors ref $self || $self,
55                                                    $wanted_class;
56                 while (@forebears) {
57                         last if shift @forebears eq $caller_class
58                 }
59                 no strict 'refs';
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}}++;
67         }
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}};
73         }
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");
79         };
80         return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
81         no strict 'refs';
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->(@_);
86 }
87
88 no strict 'vars';
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';
96
97 package EVERY::LAST;            @ISA = 'EVERY';
98 package EVERY;                  @ISA = 'NEXT';
99 sub AUTOLOAD
100 {
101         my ($self) = @_;
102         my $depth = 1;
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;
108
109         my $key = ref($self) && overload::Overloaded($self)
110             ? overload::StrVal($self) : $self;
111
112         local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
113               $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
114
115         return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
116
117         my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
118                                                            $wanted_class;
119         @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
120         no strict 'refs';
121         my %seen;
122         my @every = map { my $sub = "${_}::$wanted_method";
123                           !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
124                         } @forebears
125                                 unless $wanted_method eq 'AUTOLOAD';
126
127         my $want = wantarray;
128         if (@every) {
129                 if ($want) {
130                         return map {($_, [$self->$_(@_[1..$#_])])} @every;
131                 }
132                 elsif (defined $want) {
133                         return { map {($_, scalar($self->$_(@_[1..$#_])))}
134                                      @every
135                                };
136                 }
137                 else {
138                         $self->$_(@_[1..$#_]) for @every;
139                         return;
140                 }
141         }
142
143         @every = map { my $sub = "${_}::AUTOLOAD";
144                        !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
145                      } @forebears;
146         if ($want) {
147                 return map { $$_ = ref($self)."::EVERY::".$wanted_method;
148                              ($_, [$self->$_(@_[1..$#_])]);
149                            } @every;
150         }
151         elsif (defined $want) {
152                 return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
153                                ($_, scalar($self->$_(@_[1..$#_])))
154                              } @every
155                        };
156         }
157         else {
158                 for (@every) {
159                         $$_ = ref($self)."::EVERY::".$wanted_method;
160                         $self->$_(@_[1..$#_]);
161                 }
162                 return;
163         }
164 }
165
166
167 1;
168
169 __END__
170
171 =head1 NAME
172
173 NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
174
175
176 =head1 SYNOPSIS
177
178     use NEXT;
179
180     package A;
181     sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
182     sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
183
184     package B;
185     use base qw( A );
186     sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
187     sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
188
189     package C;
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() }
193
194     package D;
195     use base qw( B C );
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() }
199
200     package main;
201
202     my $obj = bless {}, "D";
203
204     $obj->method();             # Calls D::method, A::method, C::method
205     $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
206
207     # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
208
209
210
211 =head1 DESCRIPTION
212
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.
216
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>.
220
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.
226
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).
233
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
238 do better.
239
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.
245
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:
249
250         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
251
252
253 =head2 Enforcing redispatch
254
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.
258
259 To do this, simple invoke the redispatch as:
260
261         $self->NEXT::ACTUAL::method();
262
263 rather than:
264
265         $self->NEXT::method();
266
267 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
268 or it should throw an exception.
269
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 
272 semantics:
273
274         sub AUTOLOAD {
275                 if ($AUTOLOAD =~ /foo|bar/) {
276                         # handle here
277                 }
278                 else {  # try elsewhere
279                         shift()->NEXT::ACTUAL::AUTOLOAD(@_);
280                 }
281         }
282
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>).
286
287
288 =head2 Avoiding repetitions
289
290 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
291
292         #     A   B
293         #    / \ /
294         #   C   D
295         #    \ /
296         #     E
297
298         use NEXT;
299
300         package A;                 
301         sub foo { print "called A::foo\n"; shift->NEXT::foo() }
302
303         package B;                 
304         sub foo { print "called B::foo\n"; shift->NEXT::foo() }
305
306         package C; @ISA = qw( A );
307         sub foo { print "called C::foo\n"; shift->NEXT::foo() }
308
309         package D; @ISA = qw(A B);
310         sub foo { print "called D::foo\n"; shift->NEXT::foo() }
311
312         package E; @ISA = qw(C D);
313         sub foo { print "called E::foo\n"; shift->NEXT::foo() }
314
315         E->foo();
316
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:
322
323         called E::foo
324         called C::foo
325         called A::foo
326         called D::foo
327         called A::foo
328         called B::foo
329
330 (i.e. C<A::foo> is called twice).
331
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.
335
336 To cover such cases, you can redispatch methods via:
337
338         $self->NEXT::DISTINCT::method();
339
340 rather than:
341
342         $self->NEXT::method();
343
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:
348
349         package A;                 
350         sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
351
352         package B;                 
353         sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
354
355         package C; @ISA = qw( A );
356         sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
357
358         package D; @ISA = qw(A B);
359         sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
360
361         package E; @ISA = qw(C D);
362         sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
363
364         E->foo();
365
366 then it would print:
367         
368         called E::foo
369         called C::foo
370         called A::foo
371         called D::foo
372         called B::foo
373
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>).
376
377 Note that you can also use:
378
379         $self->NEXT::DISTINCT::ACTUAL::method();
380
381 or:
382
383         $self->NEXT::ACTUAL::DISTINCT::method();
384
385 to get both unique invocation I<and> exception-on-failure.
386
387 Note that, for historical compatibility, you can also use
388 C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
389
390
391 =head2 Invoking all versions of a method with a single call
392
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.
395 A call to:
396
397         $obj->EVERY::foo();
398
399 calls I<every> method named C<foo> that the object in C<$obj> has inherited.
400 That is:
401
402         use NEXT;
403
404         package A; @ISA = qw(B D X);
405         sub foo { print "A::foo " }
406
407         package B; @ISA = qw(D X);
408         sub foo { print "B::foo " }
409
410         package X; @ISA = qw(D);
411         sub foo { print "X::foo " }
412
413         package D;
414         sub foo { print "D::foo " }
415
416         package main;
417
418         my $obj = bless {}, 'A';
419         $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo
420
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".
425
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>.
432
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:
440
441         $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo      
442
443 you can use the C<EVERY::LAST> pseudo-class:
444
445         $obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo      
446
447 which reverses the order of method call.
448
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:
451
452 =over
453
454 =item *
455
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.
459
460 =item *
461
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.
464
465 =item *
466
467 Nothing in void context (obviously).
468
469 =back
470
471 =head2 Using C<EVERY> methods
472
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):
477
478         package Base;
479         sub DESTROY { $_[0]->EVERY::Destroy }
480
481         package Derived1; 
482         use base 'Base';
483         sub Destroy {...}
484
485         package Derived2; 
486         use base 'Base', 'Derived1';
487         sub Destroy {...}
488
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.
493
494 Likewise, to create a class hierarchy in which every initializer inherited by
495 a new object is invoked:
496
497         package Base;
498         sub new {
499                 my ($class, %args) = @_;
500                 my $obj = bless {}, $class;
501                 $obj->EVERY::LAST::Init(\%args);
502         }
503
504         package Derived1; 
505         use base 'Base';
506         sub Init {
507                 my ($argsref) = @_;
508                 ...
509         }
510
511         package Derived2; 
512         use base 'Base', 'Derived1';
513         sub Init {
514                 my ($argsref) = @_;
515                 ...
516         }
517
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.
522
523
524 =head1 AUTHOR
525
526 Damian Conway (damian@conway.org)
527
528 =head1 BUGS AND IRRITATIONS
529
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.
534
535 It's also too slow (despite caching).
536
537 Comment, suggestions, and patches welcome.
538
539 =head1 COPYRIGHT
540
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.