lib/NEXT.pm

   1 package NEXT;
   2 $VERSION = '0.60';
   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 $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
  83 no strict 'vars';
  84 package NEXT::UNSEEN;           @ISA = 'NEXT';
  85 package NEXT::DISTINCT;         @ISA = 'NEXT';
  86 package NEXT::ACTUAL;           @ISA = 'NEXT';
  87 package NEXT::ACTUAL::UNSEEN;   @ISA = 'NEXT';
  88 package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
  89 package NEXT::UNSEEN::ACTUAL;   @ISA = 'NEXT';
  90 package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
  91
  92 package EVERY::LAST;            @ISA = 'EVERY';
  93 package EVERY;                  @ISA = 'NEXT';
  94 sub 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
 157 1;
 158
 159 __END__
 160
 161 =head1 NAME
 162
 163 NEXT.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
 203 NEXT.pm adds a pseudoclass named C<NEXT> to any program
 204 that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
 205 C<m> is redispatched as if the calling method had not originally been found.
 206
 207 In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
 208 left-to-right search of C<$self>'s class hierarchy that resulted in the
 209 original call to C<m>.
 210
 211 Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
 212 begins a new dispatch that is restricted to searching the ancestors
 213 of the current class. C<$self-E<gt>NEXT::m()> can backtrack
 214 past the current class -- to look for a suitable method in other
 215 ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
 216
 217 A typical use would be in the destructors of a class hierarchy,
 218 as illustrated in the synopsis above. Each class in the hierarchy
 219 has a DESTROY method that performs some class-specific action
 220 and then redispatches the call up the hierarchy. As a result,
 221 when an object of class D is destroyed, the destructors of I<all>
 222 its parent classes are called (in depth-first, left-to-right order).
 223
 224 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
 225 If such a method determined that it was not able to handle a
 226 particular call, it might choose to redispatch that call, in the
 227 hope that some other C<AUTOLOAD> (above it, or to its left) might
 228 do better.
 229
 230 By default, if a redispatch attempt fails to find another method
 231 elsewhere in the objects class hierarchy, it quietly gives up and does
 232 nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
 233 is also unlike the (generally annoying) behaviour of C<SUPER>, which
 234 throws an exception if it cannot redispatch.
 235
 236 Note that it is a fatal error for any method (including C<AUTOLOAD>)
 237 to attempt to redispatch any method that does not have the
 238 same name. For example:
 239
 240         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
 241
 242
 243 =head2 Enforcing redispatch
 244
 245 It is possible to make C<NEXT> redispatch more demandingly (i.e. like
 246 C<SUPER> does), so that the redispatch throws an exception if it cannot
 247 find a "next" method to call.
 248
 249 To do this, simple invoke the redispatch as:
 250
 251         $self->NEXT::ACTUAL::method();
 252
 253 rather than:
 254
 255         $self->NEXT::method();
 256
 257 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
 258 or it should throw an exception.
 259
 260 C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
 261 decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
 262 semantics:
 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
 273 By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
 274 method call, an exception will be thrown (as usually happens in the absence of
 275 a suitable C<AUTOLOAD>).
 276
 277
 278 =head2 Avoiding repetitions
 279
 280 If 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
 307 then derived classes may (re-)inherit base-class methods through two or
 308 more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
 309 through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
 310 will invoke the multiply inherited method as many times as it is
 311 inherited. 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
 322 In some cases this I<may> be the desired effect within a diamond hierarchy,
 323 but in others (e.g. for destructors) it may be more appropriate to
 324 call each method only once during a sequence of redispatches.
 325
 326 To cover such cases, you can redispatch methods via:
 327
 328         $self->NEXT::DISTINCT::method();
 329
 330 rather than:
 331
 332         $self->NEXT::method();
 333
 334 This causes the redispatcher to only visit each distinct C<method> method
 335 once. That is, to skip any classes in the hierarchy that it has
 336 already visited during redispatch. So, for example, if the
 337 previous 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
 356 then 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
 364 and omit the second call to C<A::foo> (since it would not be distinct
 365 from the first call to C<A::foo>).
 366
 367 Note that you can also use:
 368
 369         $self->NEXT::DISTINCT::ACTUAL::method();
 370
 371 or:
 372
 373         $self->NEXT::ACTUAL::DISTINCT::method();
 374
 375 to get both unique invocation I<and> exception-on-failure.
 376
 377 Note that, for historical compatibility, you can also use
 378 C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
 379
 380
 381 =head2 Invoking all versions of a method with a single call
 382
 383 Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
 384 Its behaviour is considerably simpler than that of the C<NEXT> family.
 385 A call to:
 386
 387         $obj->EVERY::foo();
 388
 389 calls I<every> method named C<foo> that the object in C<$obj> has inherited.
 390 That 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
 411 Prefixing a method call with C<EVERY::> causes every method in the
 412 object's hierarchy with that name to be invoked. As the above example
 413 illustrates, they are not called in Perl's usual "left-most-depth-first"
 414 order. Instead, they are called "breadth-first-dependency-wise".
 415
 416 That means that the inheritance tree of the object is traversed breadth-first
 417 and the resulting order of classes is used as the sequence in which methods
 418 are called. However, that sequence is modified by imposing a rule that the
 419 appropritae method of a derived class must be called before the same method of
 420 any ancestral class. That's why, in the above example, C<X::foo> is called
 421 before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
 422
 423 In general, there's no need to worry about the order of calls. They will be
 424 left-to-right, breadth-first, most-derived-first. This works perfectly for
 425 most inherited methods (including destructors), but is inappropriate for
 426 some kinds of methods (such as constructors, cloners, debuggers, and
 427 initializers) where it's more appropriate that the least-derived methods be
 428 called 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
 433 you can use the C<EVERY::LAST> pseudo-class:
 434
 435         $obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo
 436
 437 which reverses the order of method call.
 438
 439 Whichever version is used, the actual methods are called in the same
 440 context (list, scalar, or void) as the original call via C<EVERY>, and return:
 441
 442 =over
 443
 444 =item *
 445
 446 A hash of array references in list context. Each entry of the hash has the
 447 fully qualified method name as its key and a reference to an array containing
 448 the method's list-context return values as its value.
 449
 450 =item *
 451
 452 A reference to a hash of scalar values in scalar context. Each entry of the hash has the
 453 fully qualified method name as its key and the method's scalar-context return values as its value.
 454
 455 =item *
 456
 457 Nothing in void context (obviously).
 458
 459 =back
 460
 461 =head2 Using C<EVERY> methods
 462
 463 The typical way to use an C<EVERY> call is to wrap it in another base
 464 method, that all classes inherit. For example, to ensure that every
 465 destructor an object inherits is actually called (as opposed to just the
 466 left-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
 479 et cetera. Every derived class than needs its own clean-up
 480 behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
 481 which the call to C<EVERY::LAST::Destroy> in the inherited destructor
 482 then correctly picks up.
 483
 484 Likewise, to create a class hierarchy in which every initializer inherited by
 485 a 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
 508 et cetera. Every derived class than needs some additional initialization
 509 behaviour simply adds its own C<Init> method (I<not> a C<new> method),
 510 which the call to C<EVERY::LAST::Init> in the inherited constructor
 511 then correctly picks up.
 512
 513
 514 =head1 AUTHOR
 515
 516 Damian Conway (damian@conway.org)
 517
 518 =head1 BUGS AND IRRITATIONS
 519
 520 Because it's a module, not an integral part of the interpreter, NEXT.pm
 521 has to guess where the surrounding call was found in the method
 522 look-up sequence. In the presence of diamond inheritance patterns
 523 it occasionally guesses wrong.
 524
 525 It's also too slow (despite caching).
 526
 527 Comment, 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.