lib/NEXT.pm

   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 acquiesence
 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 appropritae 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.