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