lib/NEXT.pm

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