1package NEXT; 2$VERSION = '0.65'; 3use Carp; 4use strict; 5use overload (); 6 7sub 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 19sub 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 33sub 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) = do { $caller =~ m{(.*)::(.*)}g }; 46 my ($wanted_class, $wanted_method) = do { $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 (do { $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 do { $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 do { ($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 101no strict 'vars'; 102package NEXT; NEXT::ELSEWHERE::buildAUTOLOAD(); 103package NEXT::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); 104package NEXT::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); 105package NEXT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); 106package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); 107package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); 108package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); 109package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); 110 111package EVERY; 112 113sub 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) = do { $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 do { $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 184package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD(); 185package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD(); 186 1871; 188 189__END__ 190 191=head1 NAME 192 193NEXT - 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 233NEXT.pm adds a pseudoclass named C<NEXT> to any program 234that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to 235C<m> is redispatched as if the calling method had not originally been found. 236 237In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first, 238left-to-right search of C<$self>'s class hierarchy that resulted in the 239original call to C<m>. 240 241Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which 242begins a new dispatch that is restricted to searching the ancestors 243of the current class. C<$self-E<gt>NEXT::m()> can backtrack 244past the current class -- to look for a suitable method in other 245ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot. 246 247A typical use would be in the destructors of a class hierarchy, 248as illustrated in the synopsis above. Each class in the hierarchy 249has a DESTROY method that performs some class-specific action 250and then redispatches the call up the hierarchy. As a result, 251when an object of class D is destroyed, the destructors of I<all> 252its parent classes are called (in depth-first, left-to-right order). 253 254Another typical use of redispatch would be in C<AUTOLOAD>'ed methods. 255If such a method determined that it was not able to handle a 256particular call, it might choose to redispatch that call, in the 257hope that some other C<AUTOLOAD> (above it, or to its left) might 258do better. 259 260By default, if a redispatch attempt fails to find another method 261elsewhere in the objects class hierarchy, it quietly gives up and does 262nothing (but see L<"Enforcing redispatch">). This gracious acquiescence 263is also unlike the (generally annoying) behaviour of C<SUPER>, which 264throws an exception if it cannot redispatch. 265 266Note that it is a fatal error for any method (including C<AUTOLOAD>) 267to attempt to redispatch any method that does not have the 268same name. For example: 269 270 sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() } 271 272 273=head2 Enforcing redispatch 274 275It is possible to make C<NEXT> redispatch more demandingly (i.e. like 276C<SUPER> does), so that the redispatch throws an exception if it cannot 277find a "next" method to call. 278 279To do this, simple invoke the redispatch as: 280 281 $self->NEXT::ACTUAL::method(); 282 283rather than: 284 285 $self->NEXT::method(); 286 287The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call, 288or it should throw an exception. 289 290C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to 291decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure 292semantics: 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 303By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the 304method call, an exception will be thrown (as usually happens in the absence of 305a suitable C<AUTOLOAD>). 306 307 308=head2 Avoiding repetitions 309 310If 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 337then derived classes may (re-)inherit base-class methods through two or 338more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice -- 339through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches 340will invoke the multiply inherited method as many times as it is 341inherited. 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 352In some cases this I<may> be the desired effect within a diamond hierarchy, 353but in others (e.g. for destructors) it may be more appropriate to 354call each method only once during a sequence of redispatches. 355 356To cover such cases, you can redispatch methods via: 357 358 $self->NEXT::DISTINCT::method(); 359 360rather than: 361 362 $self->NEXT::method(); 363 364This causes the redispatcher to only visit each distinct C<method> method 365once. That is, to skip any classes in the hierarchy that it has 366already visited during redispatch. So, for example, if the 367previous 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 386then 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 394and omit the second call to C<A::foo> (since it would not be distinct 395from the first call to C<A::foo>). 396 397Note that you can also use: 398 399 $self->NEXT::DISTINCT::ACTUAL::method(); 400 401or: 402 403 $self->NEXT::ACTUAL::DISTINCT::method(); 404 405to get both unique invocation I<and> exception-on-failure. 406 407Note that, for historical compatibility, you can also use 408C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>. 409 410 411=head2 Invoking all versions of a method with a single call 412 413Yet another pseudo-class that NEXT.pm provides is C<EVERY>. 414Its behaviour is considerably simpler than that of the C<NEXT> family. 415A call to: 416 417 $obj->EVERY::foo(); 418 419calls I<every> method named C<foo> that the object in C<$obj> has inherited. 420That 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 441Prefixing a method call with C<EVERY::> causes every method in the 442object's hierarchy with that name to be invoked. As the above example 443illustrates, they are not called in Perl's usual "left-most-depth-first" 444order. Instead, they are called "breadth-first-dependency-wise". 445 446That means that the inheritance tree of the object is traversed breadth-first 447and the resulting order of classes is used as the sequence in which methods 448are called. However, that sequence is modified by imposing a rule that the 449appropriate method of a derived class must be called before the same method of 450any ancestral class. That's why, in the above example, C<X::foo> is called 451before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>. 452 453In general, there's no need to worry about the order of calls. They will be 454left-to-right, breadth-first, most-derived-first. This works perfectly for 455most inherited methods (including destructors), but is inappropriate for 456some kinds of methods (such as constructors, cloners, debuggers, and 457initializers) where it's more appropriate that the least-derived methods be 458called 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 463you can use the C<EVERY::LAST> pseudo-class: 464 465 $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo 466 467which reverses the order of method call. 468 469Whichever version is used, the actual methods are called in the same 470context (list, scalar, or void) as the original call via C<EVERY>, and return: 471 472=over 473 474=item * 475 476A hash of array references in list context. Each entry of the hash has the 477fully qualified method name as its key and a reference to an array containing 478the method's list-context return values as its value. 479 480=item * 481 482A reference to a hash of scalar values in scalar context. Each entry of the hash has the 483fully qualified method name as its key and the method's scalar-context return values as its value. 484 485=item * 486 487Nothing in void context (obviously). 488 489=back 490 491=head2 Using C<EVERY> methods 492 493The typical way to use an C<EVERY> call is to wrap it in another base 494method, that all classes inherit. For example, to ensure that every 495destructor an object inherits is actually called (as opposed to just the 496left-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 509et cetera. Every derived class than needs its own clean-up 510behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method), 511which the call to C<EVERY::LAST::Destroy> in the inherited destructor 512then correctly picks up. 513 514Likewise, to create a class hierarchy in which every initializer inherited by 515a 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 538et cetera. Every derived class than needs some additional initialization 539behaviour simply adds its own C<Init> method (I<not> a C<new> method), 540which the call to C<EVERY::LAST::Init> in the inherited constructor 541then correctly picks up. 542 543 544=head1 AUTHOR 545 546Damian Conway (damian@conway.org) 547 548=head1 BUGS AND IRRITATIONS 549 550Because it's a module, not an integral part of the interpreter, NEXT.pm 551has to guess where the surrounding call was found in the method 552look-up sequence. In the presence of diamond inheritance patterns 553it occasionally guesses wrong. 554 555It's also too slow (despite caching). 556 557Comment, 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. 564