lib/NEXT.pm

   1 package NEXT;
   2 use Carp;
   3 use strict;
   4
   5 sub ancestors
   6 {
   7         my @inlist = @_;
   8         my @outlist = ();
   9         while (@inlist) {
  10                 push @outlist, shift @inlist;
  11                 no strict 'refs';
  12                 unshift @inlist, @{"$outlist[-1]::ISA"};
  13         }
  14         return @outlist;
  15 }
  16
  17 sub AUTOLOAD
  18 {
  19         my ($self) = @_;
  20         my $caller = (caller(1))[3];
  21         my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
  22         undef $NEXT::AUTOLOAD;
  23         my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
  24         my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
  25         croak "Can't call $wanted from $caller"
  26                 unless $caller_method eq $wanted_method;
  27
  28         local $NEXT::NEXT{$self,$wanted_method} =
  29               $NEXT::NEXT{$self,$wanted_method};
  30
  31         unless (@{$NEXT::NEXT{$self,$wanted_method}||[]}) {
  32                 my @forebears = ancestors ref $self;
  33                 while (@forebears) {
  34                         last if shift @forebears eq $caller_class
  35                 }
  36                 no strict 'refs';
  37                 @{$NEXT::NEXT{$self,$wanted_method}} =
  38                         map { *{"${_}::$caller_method"}{CODE}||() } @forebears;
  39                 @{$NEXT::NEXT{$self,$wanted_method}} =
  40                         map { *{"${_}::AUTOLOAD"}{CODE}||() } @forebears
  41                                 unless @{$NEXT::NEXT{$self,$wanted_method}};
  42         }
  43         $wanted_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
  44         return shift()->$wanted_method(@_) if $wanted_method;
  45         return;
  46 }
  47
  48 1;
  49
  50 __END__
  51
  52 =head1 NAME
  53
  54 NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
  55
  56
  57 =head1 SYNOPSIS
  58
  59         use NEXT;
  60
  61         package A;
  62         sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
  63         sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
  64
  65         package B;
  66         use base qw( A );
  67         sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  68         sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
  69
  70         package C;
  71         sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
  72         sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  73         sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }
  74
  75         package D;
  76         use base qw( B C );
  77         sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
  78         sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  79         sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }
  80
  81         package main;
  82
  83         my $obj = bless {}, "D";
  84
  85         $obj->method();         # Calls D::method, A::method, C::method
  86         $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
  87
  88         # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
  89
  90
  91 =head1 DESCRIPTION
  92
  93 NEXT.pm adds a pseudoclass named C<NEXT> to any program
  94 that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
  95 C<m> is redispatched as if the calling method had not originally been found.
  96
  97 In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
  98 left-to-right search of parent classes that resulted in the original
  99 call to C<m>.
 100
 101 A typical use would be in the destructors of a class hierarchy,
 102 as illustrated in the synopsis above. Each class in the hierarchy
 103 has a DESTROY method that performs some class-specific action
 104 and then redispatches the call up the hierarchy. As a result,
 105 when an object of class D is destroyed, the destructors of I<all>
 106 its parent classes are called (in depth-first, left-to-right order).
 107
 108 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
 109 If such a method determined that it was not able to handle a
 110 particular call, it might choose to redispatch that call, in the
 111 hope that some other C<AUTOLOAD> (above it, or to its left) might
 112 do better.
 113
 114 Note that it is a fatal error for any method (including C<AUTOLOAD>)
 115 to attempt to redispatch any method except itself. For example:
 116
 117         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
 118
 119
 120 =head1 AUTHOR
 121
 122 Damian Conway (damian@conway.org)
 123
 124 =head1 BUGS AND IRRITATIONS
 125
 126 Because it's a module, not an integral part of the interpreter, NEXT.pm
 127 has to guess where the surrounding call was found in the method
 128 look-up sequence. In the presence of diamond inheritance patterns
 129 it occasionally guesses wrong.
 130
 131 It's also too slow (despite caching).
 132
 133 Comment, suggestions, and patches welcome.
 134
 135 =head1 COPYRIGHT
 136
 137  Copyright (c) 2000, Damian Conway. All Rights Reserved.
 138  This module is free software. It may be used, redistributed
 139 and/or modified under the terms of the Perl Artistic License
 140      (see http://www.perl.com/perl/misc/Artistic.html)