lib/NEXT.pm

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