our $TODO should be local $::TODO, revealing a bug in the de-commenting regexp.
[perl.git] / lib / NEXT.pm
1 package NEXT;
2 $VERSION = '0.63';
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 NEXT::ELSEWHERE::buildAUTOLOAD
34 {
35     my $autoload_name = caller() . '::AUTOLOAD';
36
37     no strict 'refs';
38     *{$autoload_name} = sub {
39         my ($self) = @_;
40         my $depth = 1;
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;
49
50         my $key = ref $self && overload::Overloaded($self)
51             ? overload::StrVal($self) : $self;
52
53         local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
54             ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
55
56         unless ($NEXT::NEXT{$key,$wanted_method}) {
57             my @forebears =
58                 NEXT::ELSEWHERE::ancestors ref $self || $self,
59                             $wanted_class;
60             while (@forebears) {
61                 last if shift @forebears eq $caller_class
62             }
63             no strict 'refs';
64             @{$NEXT::NEXT{$key,$wanted_method}} =
65                 map {
66                     my $stash = \%{"${_}::"};
67                     ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE}))
68                         ? *{$stash->{$caller_method}}{CODE}
69                         : () } @forebears
70                     unless $wanted_method eq 'AUTOLOAD';
71             @{$NEXT::NEXT{$key,$wanted_method}} =
72                 map {
73                     my $stash = \%{"${_}::"};
74                     ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE}))
75                         ? "${_}::AUTOLOAD"
76                         : () } @forebears
77                     unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
78             $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
79         }
80         my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
81         while ($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}};
85         }
86         unless (defined $call_method) {
87             return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
88             (local $Carp::CarpLevel)++;
89             croak qq(Can't locate object method "$wanted_method" ),
90                 qq(via package "$caller_class");
91         };
92         return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
93         no strict 'refs';
94         ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
95             if $wanted_method eq 'AUTOLOAD';
96         $$call_method = $caller_class."::NEXT::".$wanted_method;
97         return $call_method->(@_);
98     };
99 }
100
101 no strict 'vars';
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();
110
111 package EVERY;
112
113 sub EVERY::ELSEWHERE::buildAUTOLOAD {
114     my $autoload_name = caller() . '::AUTOLOAD';
115
116     no strict 'refs';
117     *{$autoload_name} = sub {
118         my ($self) = @_;
119         my $depth = 1;
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) = $wanted =~ m{(.*)::(.*)}g;
125
126         my $key = ref($self) && overload::Overloaded($self)
127             ? overload::StrVal($self) : $self;
128
129         local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
130             $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
131
132         return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
133
134         my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
135                                         $wanted_class;
136         @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
137         no strict 'refs';
138         my %seen;
139         my @every = map { my $sub = "${_}::$wanted_method";
140                     !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
141                     } @forebears
142                     unless $wanted_method eq 'AUTOLOAD';
143
144         my $want = wantarray;
145         if (@every) {
146             if ($want) {
147                 return map {($_, [$self->$_(@_[1..$#_])])} @every;
148             }
149             elsif (defined $want) {
150                 return { map {($_, scalar($self->$_(@_[1..$#_])))}
151                         @every
152                     };
153             }
154             else {
155                 $self->$_(@_[1..$#_]) for @every;
156                 return;
157             }
158         }
159
160         @every = map { my $sub = "${_}::AUTOLOAD";
161                 !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
162                 } @forebears;
163         if ($want) {
164             return map { $$_ = ref($self)."::EVERY::".$wanted_method;
165                     ($_, [$self->$_(@_[1..$#_])]);
166                 } @every;
167         }
168         elsif (defined $want) {
169             return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
170                     ($_, scalar($self->$_(@_[1..$#_])))
171                     } @every
172                 };
173         }
174         else {
175             for (@every) {
176                 $$_ = ref($self)."::EVERY::".$wanted_method;
177                 $self->$_(@_[1..$#_]);
178             }
179             return;
180         }
181     };
182 }
183
184 package EVERY::LAST;   @ISA = 'EVERY';   EVERY::ELSEWHERE::buildAUTOLOAD();
185 package EVERY;         @ISA = 'NEXT';    EVERY::ELSEWHERE::buildAUTOLOAD();
186
187 1;
188
189 __END__
190
191 =head1 NAME
192
193 NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
194
195
196 =head1 SYNOPSIS
197
198     use NEXT;
199
200     package A;
201     sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
202     sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
203
204     package B;
205     use base qw( A );
206     sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
207     sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
208
209     package C;
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() }
213
214     package D;
215     use base qw( B C );
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() }
219
220     package main;
221
222     my $obj = bless {}, "D";
223
224     $obj->method();             # Calls D::method, A::method, C::method
225     $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
226
227     # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
228
229
230
231 =head1 DESCRIPTION
232
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.
236
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>.
240
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.
246
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).
253
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
258 do better.
259
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.
265
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:
269
270         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
271
272
273 =head2 Enforcing redispatch
274
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.
278
279 To do this, simple invoke the redispatch as:
280
281         $self->NEXT::ACTUAL::method();
282
283 rather than:
284
285         $self->NEXT::method();
286
287 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
288 or it should throw an exception.
289
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 
292 semantics:
293
294         sub AUTOLOAD {
295                 if ($AUTOLOAD =~ /foo|bar/) {
296                         # handle here
297                 }
298                 else {  # try elsewhere
299                         shift()->NEXT::ACTUAL::AUTOLOAD(@_);
300                 }
301         }
302
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>).
306
307
308 =head2 Avoiding repetitions
309
310 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
311
312         #     A   B
313         #    / \ /
314         #   C   D
315         #    \ /
316         #     E
317
318         use NEXT;
319
320         package A;                 
321         sub foo { print "called A::foo\n"; shift->NEXT::foo() }
322
323         package B;                 
324         sub foo { print "called B::foo\n"; shift->NEXT::foo() }
325
326         package C; @ISA = qw( A );
327         sub foo { print "called C::foo\n"; shift->NEXT::foo() }
328
329         package D; @ISA = qw(A B);
330         sub foo { print "called D::foo\n"; shift->NEXT::foo() }
331
332         package E; @ISA = qw(C D);
333         sub foo { print "called E::foo\n"; shift->NEXT::foo() }
334
335         E->foo();
336
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:
342
343         called E::foo
344         called C::foo
345         called A::foo
346         called D::foo
347         called A::foo
348         called B::foo
349
350 (i.e. C<A::foo> is called twice).
351
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.
355
356 To cover such cases, you can redispatch methods via:
357
358         $self->NEXT::DISTINCT::method();
359
360 rather than:
361
362         $self->NEXT::method();
363
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:
368
369         package A;                 
370         sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
371
372         package B;                 
373         sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
374
375         package C; @ISA = qw( A );
376         sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
377
378         package D; @ISA = qw(A B);
379         sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
380
381         package E; @ISA = qw(C D);
382         sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
383
384         E->foo();
385
386 then it would print:
387         
388         called E::foo
389         called C::foo
390         called A::foo
391         called D::foo
392         called B::foo
393
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>).
396
397 Note that you can also use:
398
399         $self->NEXT::DISTINCT::ACTUAL::method();
400
401 or:
402
403         $self->NEXT::ACTUAL::DISTINCT::method();
404
405 to get both unique invocation I<and> exception-on-failure.
406
407 Note that, for historical compatibility, you can also use
408 C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
409
410
411 =head2 Invoking all versions of a method with a single call
412
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.
415 A call to:
416
417         $obj->EVERY::foo();
418
419 calls I<every> method named C<foo> that the object in C<$obj> has inherited.
420 That is:
421
422         use NEXT;
423
424         package A; @ISA = qw(B D X);
425         sub foo { print "A::foo " }
426
427         package B; @ISA = qw(D X);
428         sub foo { print "B::foo " }
429
430         package X; @ISA = qw(D);
431         sub foo { print "X::foo " }
432
433         package D;
434         sub foo { print "D::foo " }
435
436         package main;
437
438         my $obj = bless {}, 'A';
439         $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo
440
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".
445
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>.
452
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:
460
461         $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo      
462
463 you can use the C<EVERY::LAST> pseudo-class:
464
465         $obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo      
466
467 which reverses the order of method call.
468
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:
471
472 =over
473
474 =item *
475
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.
479
480 =item *
481
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.
484
485 =item *
486
487 Nothing in void context (obviously).
488
489 =back
490
491 =head2 Using C<EVERY> methods
492
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):
497
498         package Base;
499         sub DESTROY { $_[0]->EVERY::Destroy }
500
501         package Derived1; 
502         use base 'Base';
503         sub Destroy {...}
504
505         package Derived2; 
506         use base 'Base', 'Derived1';
507         sub Destroy {...}
508
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.
513
514 Likewise, to create a class hierarchy in which every initializer inherited by
515 a new object is invoked:
516
517         package Base;
518         sub new {
519                 my ($class, %args) = @_;
520                 my $obj = bless {}, $class;
521                 $obj->EVERY::LAST::Init(\%args);
522         }
523
524         package Derived1; 
525         use base 'Base';
526         sub Init {
527                 my ($argsref) = @_;
528                 ...
529         }
530
531         package Derived2; 
532         use base 'Base', 'Derived1';
533         sub Init {
534                 my ($argsref) = @_;
535                 ...
536         }
537
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.
542
543
544 =head1 AUTHOR
545
546 Damian Conway (damian@conway.org)
547
548 =head1 BUGS AND IRRITATIONS
549
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.
554
555 It's also too slow (despite caching).
556
557 Comment, suggestions, and patches welcome.
558
559 =head1 COPYRIGHT
560
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.