[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.