lib/NEXT.pm

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