extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / NEXT.pm
CommitLineData
e4783b1c 1package NEXT;
874ad44d 2$VERSION = '0.60_01';
e4783b1c 3use Carp;
4use strict;
5
52138ef3 6sub NEXT::ELSEWHERE::ancestors
e4783b1c 7{
13021a80 8 my @inlist = shift;
e4783b1c 9 my @outlist = ();
13021a80 10 while (my $next = shift @inlist) {
11 push @outlist, $next;
e4783b1c 12 no strict 'refs';
13 unshift @inlist, @{"$outlist[-1]::ISA"};
14 }
15 return @outlist;
16}
17
bf5734d4 18sub 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
e4783b1c 32sub AUTOLOAD
33{
34 my ($self) = @_;
874ad44d 35 my $depth = 1;
36 until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
37 my $caller = (caller($depth))[3];
e4783b1c 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
13021a80 45 local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
46 ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
e4783b1c 47
13021a80 48
49 unless ($NEXT::NEXT{$self,$wanted_method}) {
50 my @forebears =
52138ef3 51 NEXT::ELSEWHERE::ancestors ref $self || $self,
52 $wanted_class;
e4783b1c 53 while (@forebears) {
54 last if shift @forebears eq $caller_class
55 }
56 no strict 'refs';
57 @{$NEXT::NEXT{$self,$wanted_method}} =
55a1c97c 58 map { *{"${_}::$caller_method"}{CODE}||() } @forebears
59 unless $wanted_method eq 'AUTOLOAD';
e4783b1c 60 @{$NEXT::NEXT{$self,$wanted_method}} =
13021a80 61 map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
55a1c97c 62 unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
52138ef3 63 $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
55a1c97c 64 }
65 my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
bf5734d4 66 while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
67 && defined $call_method
13021a80 68 && $NEXT::SEEN->{$self,$call_method}++) {
69 $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
e4783b1c 70 }
13021a80 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 };
52138ef3 77 return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
13021a80 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->(@_);
e4783b1c 83}
84
13021a80 85no strict 'vars';
86package NEXT::UNSEEN; @ISA = 'NEXT';
52138ef3 87package NEXT::DISTINCT; @ISA = 'NEXT';
13021a80 88package NEXT::ACTUAL; @ISA = 'NEXT';
89package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
52138ef3 90package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
13021a80 91package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
52138ef3 92package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
bf5734d4 93
94package EVERY::LAST; @ISA = 'EVERY';
52138ef3 95package EVERY; @ISA = 'NEXT';
bf5734d4 96sub AUTOLOAD
97{
98 my ($self) = @_;
874ad44d 99 my $depth = 1;
100 until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ }
101 my $caller = (caller($depth))[3];
bf5734d4 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
13021a80 160
e4783b1c 1611;
162
163__END__
164
165=head1 NAME
166
bf5734d4 167NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
e4783b1c 168
169
170=head1 SYNOPSIS
171
13021a80 172 use NEXT;
e4783b1c 173
13021a80 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() }
e4783b1c 177
13021a80 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() }
e4783b1c 182
13021a80 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() }
e4783b1c 187
13021a80 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() }
e4783b1c 193
13021a80 194 package main;
e4783b1c 195
13021a80 196 my $obj = bless {}, "D";
e4783b1c 197
13021a80 198 $obj->method(); # Calls D::method, A::method, C::method
199 $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
e4783b1c 200
13021a80 201 # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
e4783b1c 202
203
bf5734d4 204
e4783b1c 205=head1 DESCRIPTION
206
207NEXT.pm adds a pseudoclass named C<NEXT> to any program
e23eab12 208that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
e4783b1c 209C<m> is redispatched as if the calling method had not originally been found.
210
e23eab12 211In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
55a1c97c 212left-to-right search of C<$self>'s class hierarchy that resulted in the
213original call to C<m>.
214
e23eab12 215Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
55a1c97c 216begins a new dispatch that is restricted to searching the ancestors
e23eab12 217of the current class. C<$self-E<gt>NEXT::m()> can backtrack
55a1c97c 218past the current class -- to look for a suitable method in other
e23eab12 219ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
e4783b1c 220
221A typical use would be in the destructors of a class hierarchy,
222as illustrated in the synopsis above. Each class in the hierarchy
223has a DESTROY method that performs some class-specific action
224and then redispatches the call up the hierarchy. As a result,
225when an object of class D is destroyed, the destructors of I<all>
226its parent classes are called (in depth-first, left-to-right order).
227
228Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
229If such a method determined that it was not able to handle a
230particular call, it might choose to redispatch that call, in the
231hope that some other C<AUTOLOAD> (above it, or to its left) might
232do better.
233
13021a80 234By default, if a redispatch attempt fails to find another method
235elsewhere in the objects class hierarchy, it quietly gives up and does
236nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
237is also unlike the (generally annoying) behaviour of C<SUPER>, which
238throws an exception if it cannot redispatch.
239
e4783b1c 240Note that it is a fatal error for any method (including C<AUTOLOAD>)
13021a80 241to attempt to redispatch any method that does not have the
242same name. For example:
243
244 sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
245
246
247=head2 Enforcing redispatch
248
249It is possible to make C<NEXT> redispatch more demandingly (i.e. like
250C<SUPER> does), so that the redispatch throws an exception if it cannot
251find a "next" method to call.
252
253To do this, simple invoke the redispatch as:
254
255 $self->NEXT::ACTUAL::method();
256
257rather than:
258
259 $self->NEXT::method();
260
261The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
262or it should throw an exception.
263
264C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
265decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
266semantics:
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
277By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
278method call, an exception will be thrown (as usually happens in the absence of
279a suitable C<AUTOLOAD>).
280
281
282=head2 Avoiding repetitions
283
284If 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
311then derived classes may (re-)inherit base-class methods through two or
312more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
313through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
314will invoke the multiply inherited method as many times as it is
315inherited. 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
326In some cases this I<may> be the desired effect within a diamond hierarchy,
327but in others (e.g. for destructors) it may be more appropriate to
328call each method only once during a sequence of redispatches.
329
330To cover such cases, you can redispatch methods via:
331
52138ef3 332 $self->NEXT::DISTINCT::method();
13021a80 333
334rather than:
335
336 $self->NEXT::method();
337
52138ef3 338This causes the redispatcher to only visit each distinct C<method> method
339once. That is, to skip any classes in the hierarchy that it has
340already visited during redispatch. So, for example, if the
13021a80 341previous example were rewritten:
342
343 package A;
52138ef3 344 sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 345
346 package B;
52138ef3 347 sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 348
349 package C; @ISA = qw( A );
52138ef3 350 sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 351
352 package D; @ISA = qw(A B);
52138ef3 353 sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 354
355 package E; @ISA = qw(C D);
52138ef3 356 sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
13021a80 357
358 E->foo();
359
360then 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
52138ef3 368and omit the second call to C<A::foo> (since it would not be distinct
369from the first call to C<A::foo>).
13021a80 370
371Note that you can also use:
372
52138ef3 373 $self->NEXT::DISTINCT::ACTUAL::method();
13021a80 374
375or:
376
52138ef3 377 $self->NEXT::ACTUAL::DISTINCT::method();
e4783b1c 378
13021a80 379to get both unique invocation I<and> exception-on-failure.
e4783b1c 380
52138ef3 381Note that, for historical compatibility, you can also use
382C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
e4783b1c 383
bf5734d4 384
385=head2 Invoking all versions of a method with a single call
386
387Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
388Its behaviour is considerably simpler than that of the C<NEXT> family.
389A call to:
390
391 $obj->EVERY::foo();
392
393calls I<every> method named C<foo> that the object in C<$obj> has inherited.
394That 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
415Prefixing a method call with C<EVERY::> causes every method in the
416object's hierarchy with that name to be invoked. As the above example
417illustrates, they are not called in Perl's usual "left-most-depth-first"
418order. Instead, they are called "breadth-first-dependency-wise".
419
420That means that the inheritance tree of the object is traversed breadth-first
421and the resulting order of classes is used as the sequence in which methods
422are called. However, that sequence is modified by imposing a rule that the
423appropritae method of a derived class must be called before the same method of
424any ancestral class. That's why, in the above example, C<X::foo> is called
425before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
426
427In general, there's no need to worry about the order of calls. They will be
428left-to-right, breadth-first, most-derived-first. This works perfectly for
429most inherited methods (including destructors), but is inappropriate for
430some kinds of methods (such as constructors, cloners, debuggers, and
431initializers) where it's more appropriate that the least-derived methods be
432called 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
437you can use the C<EVERY::LAST> pseudo-class:
438
439 $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
440
441which reverses the order of method call.
442
443Whichever version is used, the actual methods are called in the same
444context (list, scalar, or void) as the original call via C<EVERY>, and return:
445
446=over
447
448=item *
449
450A hash of array references in list context. Each entry of the hash has the
451fully qualified method name as its key and a reference to an array containing
452the method's list-context return values as its value.
453
454=item *
455
456A reference to a hash of scalar values in scalar context. Each entry of the hash has the
457fully qualified method name as its key and the method's scalar-context return values as its value.
458
459=item *
460
461Nothing in void context (obviously).
462
463=back
464
465=head2 Using C<EVERY> methods
466
467The typical way to use an C<EVERY> call is to wrap it in another base
468method, that all classes inherit. For example, to ensure that every
469destructor an object inherits is actually called (as opposed to just the
470left-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
483et cetera. Every derived class than needs its own clean-up
484behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
485which the call to C<EVERY::LAST::Destroy> in the inherited destructor
486then correctly picks up.
487
488Likewise, to create a class hierarchy in which every initializer inherited by
489a 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
512et cetera. Every derived class than needs some additional initialization
513behaviour simply adds its own C<Init> method (I<not> a C<new> method),
514which the call to C<EVERY::LAST::Init> in the inherited constructor
515then correctly picks up.
516
517
e4783b1c 518=head1 AUTHOR
519
520Damian Conway (damian@conway.org)
521
522=head1 BUGS AND IRRITATIONS
523
524Because it's a module, not an integral part of the interpreter, NEXT.pm
525has to guess where the surrounding call was found in the method
526look-up sequence. In the presence of diamond inheritance patterns
527it occasionally guesses wrong.
528
529It's also too slow (despite caching).
530
531Comment, suggestions, and patches welcome.
532
533=head1 COPYRIGHT
534
55a1c97c 535 Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
e4783b1c 536 This module is free software. It may be used, redistributed
55a1c97c 537 and/or modified under the same terms as Perl itself.