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