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