extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / NEXT.pm
1 package NEXT;
2 $VERSION = '0.60_01';
3 use Carp;
4 use strict;
5
6 sub NEXT::ELSEWHERE::ancestors
7 {
8         my @inlist = shift;
9         my @outlist = ();
10         while (my $next = shift @inlist) {
11                 push @outlist, $next;
12                 no strict 'refs';
13                 unshift @inlist, @{"$outlist[-1]::ISA"};
14         }
15         return @outlist;
16 }
17
18 sub NEXT::ELSEWHERE::ordered_ancestors
19 {
20         my @inlist = shift;
21         my @outlist = ();
22         while (my $next = shift @inlist) {
23                 push @outlist, $next;
24                 no strict 'refs';
25                 push @inlist, @{"$outlist[-1]::ISA"};
26         }
27         return sort { $a->isa($b) ? -1
28                     : $b->isa($a) ? +1
29                     :                0 } @outlist;
30 }
31
32 sub AUTOLOAD
33 {
34         my ($self) = @_;
35         my $depth = 1;
36         until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
37         my $caller = (caller($depth))[3];
38         my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
39         undef $NEXT::AUTOLOAD;
40         my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
41         my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
42         croak "Can't call $wanted from $caller"
43                 unless $caller_method eq $wanted_method;
44
45         local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
46               ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
47
48
49         unless ($NEXT::NEXT{$self,$wanted_method}) {
50                 my @forebears =
51                         NEXT::ELSEWHERE::ancestors ref $self || $self,
52                                                    $wanted_class;
53                 while (@forebears) {
54                         last if shift @forebears eq $caller_class
55                 }
56                 no strict 'refs';
57                 @{$NEXT::NEXT{$self,$wanted_method}} = 
58                         map { *{"${_}::$caller_method"}{CODE}||() } @forebears
59                                 unless $wanted_method eq 'AUTOLOAD';
60                 @{$NEXT::NEXT{$self,$wanted_method}} = 
61                         map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
62                                 unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
63                 $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
64         }
65         my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
66         while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
67                && defined $call_method
68                && $NEXT::SEEN->{$self,$call_method}++) {
69                 $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
70         }
71         unless (defined $call_method) {
72                 return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
73                 (local $Carp::CarpLevel)++;
74                 croak qq(Can't locate object method "$wanted_method" ),
75                       qq(via package "$caller_class");
76         };
77         return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
78         no strict 'refs';
79         ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
80                 if $wanted_method eq 'AUTOLOAD';
81         $$call_method = $caller_class."::NEXT::".$wanted_method;
82         return $call_method->(@_);
83 }
84
85 no strict 'vars';
86 package NEXT::UNSEEN;           @ISA = 'NEXT';
87 package NEXT::DISTINCT;         @ISA = 'NEXT';
88 package NEXT::ACTUAL;           @ISA = 'NEXT';
89 package NEXT::ACTUAL::UNSEEN;   @ISA = 'NEXT';
90 package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
91 package NEXT::UNSEEN::ACTUAL;   @ISA = 'NEXT';
92 package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
93
94 package EVERY::LAST;            @ISA = 'EVERY';
95 package EVERY;                  @ISA = 'NEXT';
96 sub AUTOLOAD
97 {
98         my ($self) = @_;
99         my $depth = 1;
100         until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
101         my $caller = (caller($depth))[3];
102         my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD';
103         undef $EVERY::AUTOLOAD;
104         my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
105
106         local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} =
107               $NEXT::ALREADY_IN_EVERY{$self,$wanted_method};
108
109         return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++;
110         
111         my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
112                                                            $wanted_class;
113         @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
114         no strict 'refs';
115         my %seen;
116         my @every = map { my $sub = "${_}::$wanted_method";
117                           !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
118                         } @forebears
119                                 unless $wanted_method eq 'AUTOLOAD';
120
121         my $want = wantarray;
122         if (@every) {
123                 if ($want) {
124                         return map {($_, [$self->$_(@_[1..$#_])])} @every;
125                 }
126                 elsif (defined $want) {
127                         return { map {($_, scalar($self->$_(@_[1..$#_])))}
128                                      @every
129                                };
130                 }
131                 else {
132                         $self->$_(@_[1..$#_]) for @every;
133                         return;
134                 }
135         }
136
137         @every = map { my $sub = "${_}::AUTOLOAD";
138                        !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
139                      } @forebears;
140         if ($want) {
141                 return map { $$_ = ref($self)."::EVERY::".$wanted_method;
142                              ($_, [$self->$_(@_[1..$#_])]);
143                            } @every;
144         }
145         elsif (defined $want) {
146                 return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
147                                ($_, scalar($self->$_(@_[1..$#_])))
148                              } @every
149                        };
150         }
151         else {
152                 for (@every) {
153                         $$_ = ref($self)."::EVERY::".$wanted_method;
154                         $self->$_(@_[1..$#_]);
155                 }
156                 return;
157         }
158 }
159
160
161 1;
162
163 __END__
164
165 =head1 NAME
166
167 NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
168
169
170 =head1 SYNOPSIS
171
172     use NEXT;
173
174     package A;
175     sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
176     sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
177
178     package B;
179     use base qw( A );
180     sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
181     sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
182
183     package C;
184     sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
185     sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
186     sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }
187
188     package D;
189     use base qw( B C );
190     sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
191     sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
192     sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }
193
194     package main;
195
196     my $obj = bless {}, "D";
197
198     $obj->method();             # Calls D::method, A::method, C::method
199     $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
200
201     # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
202
203
204
205 =head1 DESCRIPTION
206
207 NEXT.pm adds a pseudoclass named C<NEXT> to any program
208 that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
209 C<m> is redispatched as if the calling method had not originally been found.
210
211 In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
212 left-to-right search of C<$self>'s class hierarchy that resulted in the
213 original call to C<m>.
214
215 Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
216 begins a new dispatch that is restricted to searching the ancestors
217 of the current class. C<$self-E<gt>NEXT::m()> can backtrack
218 past the current class -- to look for a suitable method in other
219 ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
220
221 A typical use would be in the destructors of a class hierarchy,
222 as illustrated in the synopsis above. Each class in the hierarchy
223 has a DESTROY method that performs some class-specific action
224 and then redispatches the call up the hierarchy. As a result,
225 when an object of class D is destroyed, the destructors of I<all>
226 its parent classes are called (in depth-first, left-to-right order).
227
228 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
229 If such a method determined that it was not able to handle a
230 particular call, it might choose to redispatch that call, in the
231 hope that some other C<AUTOLOAD> (above it, or to its left) might
232 do better.
233
234 By default, if a redispatch attempt fails to find another method
235 elsewhere in the objects class hierarchy, it quietly gives up and does
236 nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
237 is also unlike the (generally annoying) behaviour of C<SUPER>, which
238 throws an exception if it cannot redispatch.
239
240 Note that it is a fatal error for any method (including C<AUTOLOAD>)
241 to attempt to redispatch any method that does not have the
242 same name. For example:
243
244         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
245
246
247 =head2 Enforcing redispatch
248
249 It is possible to make C<NEXT> redispatch more demandingly (i.e. like
250 C<SUPER> does), so that the redispatch throws an exception if it cannot
251 find a "next" method to call.
252
253 To do this, simple invoke the redispatch as:
254
255         $self->NEXT::ACTUAL::method();
256
257 rather than:
258
259         $self->NEXT::method();
260
261 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
262 or it should throw an exception.
263
264 C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
265 decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure 
266 semantics:
267
268         sub AUTOLOAD {
269                 if ($AUTOLOAD =~ /foo|bar/) {
270                         # handle here
271                 }
272                 else {  # try elsewhere
273                         shift()->NEXT::ACTUAL::AUTOLOAD(@_);
274                 }
275         }
276
277 By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
278 method call, an exception will be thrown (as usually happens in the absence of
279 a suitable C<AUTOLOAD>).
280
281
282 =head2 Avoiding repetitions
283
284 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
285
286         #     A   B
287         #    / \ /
288         #   C   D
289         #    \ /
290         #     E
291
292         use NEXT;
293
294         package A;                 
295         sub foo { print "called A::foo\n"; shift->NEXT::foo() }
296
297         package B;                 
298         sub foo { print "called B::foo\n"; shift->NEXT::foo() }
299
300         package C; @ISA = qw( A );
301         sub foo { print "called C::foo\n"; shift->NEXT::foo() }
302
303         package D; @ISA = qw(A B);
304         sub foo { print "called D::foo\n"; shift->NEXT::foo() }
305
306         package E; @ISA = qw(C D);
307         sub foo { print "called E::foo\n"; shift->NEXT::foo() }
308
309         E->foo();
310
311 then derived classes may (re-)inherit base-class methods through two or
312 more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
313 through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
314 will invoke the multiply inherited method as many times as it is
315 inherited. For example, the above code prints:
316
317         called E::foo
318         called C::foo
319         called A::foo
320         called D::foo
321         called A::foo
322         called B::foo
323
324 (i.e. C<A::foo> is called twice).
325
326 In some cases this I<may> be the desired effect within a diamond hierarchy,
327 but in others (e.g. for destructors) it may be more appropriate to 
328 call each method only once during a sequence of redispatches.
329
330 To cover such cases, you can redispatch methods via:
331
332         $self->NEXT::DISTINCT::method();
333
334 rather than:
335
336         $self->NEXT::method();
337
338 This causes the redispatcher to only visit each distinct C<method> method
339 once. That is, to skip any classes in the hierarchy that it has
340 already visited during redispatch. So, for example, if the
341 previous example were rewritten:
342
343         package A;                 
344         sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
345
346         package B;                 
347         sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
348
349         package C; @ISA = qw( A );
350         sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
351
352         package D; @ISA = qw(A B);
353         sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
354
355         package E; @ISA = qw(C D);
356         sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
357
358         E->foo();
359
360 then it would print:
361         
362         called E::foo
363         called C::foo
364         called A::foo
365         called D::foo
366         called B::foo
367
368 and omit the second call to C<A::foo> (since it would not be distinct
369 from the first call to C<A::foo>).
370
371 Note that you can also use:
372
373         $self->NEXT::DISTINCT::ACTUAL::method();
374
375 or:
376
377         $self->NEXT::ACTUAL::DISTINCT::method();
378
379 to get both unique invocation I<and> exception-on-failure.
380
381 Note that, for historical compatibility, you can also use
382 C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
383
384
385 =head2 Invoking all versions of a method with a single call
386
387 Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
388 Its behaviour is considerably simpler than that of the C<NEXT> family.
389 A call to:
390
391         $obj->EVERY::foo();
392
393 calls I<every> method named C<foo> that the object in C<$obj> has inherited.
394 That is:
395
396         use NEXT;
397
398         package A; @ISA = qw(B D X);
399         sub foo { print "A::foo " }
400
401         package B; @ISA = qw(D X);
402         sub foo { print "B::foo " }
403
404         package X; @ISA = qw(D);
405         sub foo { print "X::foo " }
406
407         package D;
408         sub foo { print "D::foo " }
409
410         package main;
411
412         my $obj = bless {}, 'A';
413         $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo
414
415 Prefixing a method call with C<EVERY::> causes every method in the
416 object's hierarchy with that name to be invoked. As the above example
417 illustrates, they are not called in Perl's usual "left-most-depth-first"
418 order. Instead, they are called "breadth-first-dependency-wise".
419
420 That means that the inheritance tree of the object is traversed breadth-first
421 and the resulting order of classes is used as the sequence in which methods
422 are called. However, that sequence is modified by imposing a rule that the
423 appropritae method of a derived class must be called before the same method of
424 any ancestral class. That's why, in the above example, C<X::foo> is called
425 before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
426
427 In general, there's no need to worry about the order of calls. They will be
428 left-to-right, breadth-first, most-derived-first. This works perfectly for
429 most inherited methods (including destructors), but is inappropriate for
430 some kinds of methods (such as constructors, cloners, debuggers, and
431 initializers) where it's more appropriate that the least-derived methods be
432 called first (as more-derived methods may rely on the behaviour of their
433 "ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
434
435         $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo      
436
437 you can use the C<EVERY::LAST> pseudo-class:
438
439         $obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo      
440
441 which reverses the order of method call.
442
443 Whichever version is used, the actual methods are called in the same
444 context (list, scalar, or void) as the original call via C<EVERY>, and return:
445
446 =over
447
448 =item *
449
450 A hash of array references in list context. Each entry of the hash has the
451 fully qualified method name as its key and a reference to an array containing
452 the method's list-context return values as its value.
453
454 =item *
455
456 A reference to a hash of scalar values in scalar context. Each entry of the hash has the
457 fully qualified method name as its key and the method's scalar-context return values as its value.
458
459 =item *
460
461 Nothing in void context (obviously).
462
463 =back
464
465 =head2 Using C<EVERY> methods
466
467 The typical way to use an C<EVERY> call is to wrap it in another base
468 method, that all classes inherit. For example, to ensure that every
469 destructor an object inherits is actually called (as opposed to just the
470 left-most-depth-first-est one):
471
472         package Base;
473         sub DESTROY { $_[0]->EVERY::Destroy }
474
475         package Derived1; 
476         use base 'Base';
477         sub Destroy {...}
478
479         package Derived2; 
480         use base 'Base', 'Derived1';
481         sub Destroy {...}
482
483 et cetera. Every derived class than needs its own clean-up
484 behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
485 which the call to C<EVERY::LAST::Destroy> in the inherited destructor
486 then correctly picks up.
487
488 Likewise, to create a class hierarchy in which every initializer inherited by
489 a new object is invoked:
490
491         package Base;
492         sub new {
493                 my ($class, %args) = @_;
494                 my $obj = bless {}, $class;
495                 $obj->EVERY::LAST::Init(\%args);
496         }
497
498         package Derived1; 
499         use base 'Base';
500         sub Init {
501                 my ($argsref) = @_;
502                 ...
503         }
504
505         package Derived2; 
506         use base 'Base', 'Derived1';
507         sub Init {
508                 my ($argsref) = @_;
509                 ...
510         }
511
512 et cetera. Every derived class than needs some additional initialization
513 behaviour simply adds its own C<Init> method (I<not> a C<new> method),
514 which the call to C<EVERY::LAST::Init> in the inherited constructor
515 then correctly picks up.
516
517
518 =head1 AUTHOR
519
520 Damian Conway (damian@conway.org)
521
522 =head1 BUGS AND IRRITATIONS
523
524 Because it's a module, not an integral part of the interpreter, NEXT.pm
525 has to guess where the surrounding call was found in the method
526 look-up sequence. In the presence of diamond inheritance patterns
527 it occasionally guesses wrong.
528
529 It's also too slow (despite caching).
530
531 Comment, suggestions, and patches welcome.
532
533 =head1 COPYRIGHT
534
535  Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
536  This module is free software. It may be used, redistributed
537     and/or modified under the same terms as Perl itself.