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