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                                 unless $wanted_method eq 'AUTOLOAD';
  40                 @{$NEXT::NEXT{$self,$wanted_method}} =
  41                         map { (*{"${_}::AUTOLOAD"}{CODE}) ?
  42                                                 "${_}::AUTOLOAD" : () } @forebears
  43                                 unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
  44         }
  45         my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
  46         return unless defined $call_method;
  47         if (ref $call_method eq 'CODE') {
  48                 return shift()->$call_method(@_)
  49         }
  50         else {  # AN AUTOLOAD
  51                 no strict 'refs';
  52                 ${$call_method} = $caller_method eq 'AUTOLOAD' && ${"${caller_class}::AUTOLOAD"} || $wanted;
  53                 return $call_method->(@_);
  54         }
  55 }
  56
  57 1;
  58
  59 __END__
  60
  61 =head1 NAME
  62
  63 NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
  64
  65
  66 =head1 SYNOPSIS
  67
  68         use NEXT;
  69
  70         package A;
  71         sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
  72         sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
  73
  74         package B;
  75         use base qw( A );
  76         sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  77         sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
  78
  79         package C;
  80         sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
  81         sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  82         sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }
  83
  84         package D;
  85         use base qw( B C );
  86         sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
  87         sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  88         sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }
  89
  90         package main;
  91
  92         my $obj = bless {}, "D";
  93
  94         $obj->method();         # Calls D::method, A::method, C::method
  95         $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
  96
  97         # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
  98
  99
 100 =head1 DESCRIPTION
 101
 102 NEXT.pm adds a pseudoclass named C<NEXT> to any program
 103 that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
 104 C<m> is redispatched as if the calling method had not originally been found.
 105
 106 In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
 107 left-to-right search of C<$self>'s class hierarchy that resulted in the
 108 original call to C<m>.
 109
 110 Note that this is not the same thing as C<$self->SUPER::m()>, which
 111 begins a new dispatch that is restricted to searching the ancestors
 112 of the current class. C<$self->NEXT::m()> can backtrack
 113 past the current class -- to look for a suitable method in other
 114 ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot.
 115
 116 A typical use would be in the destructors of a class hierarchy,
 117 as illustrated in the synopsis above. Each class in the hierarchy
 118 has a DESTROY method that performs some class-specific action
 119 and then redispatches the call up the hierarchy. As a result,
 120 when an object of class D is destroyed, the destructors of I<all>
 121 its parent classes are called (in depth-first, left-to-right order).
 122
 123 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
 124 If such a method determined that it was not able to handle a
 125 particular call, it might choose to redispatch that call, in the
 126 hope that some other C<AUTOLOAD> (above it, or to its left) might
 127 do better.
 128
 129 Note that it is a fatal error for any method (including C<AUTOLOAD>)
 130 to attempt to redispatch any method except itself. For example:
 131
 132         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
 133
 134
 135 =head1 AUTHOR
 136
 137 Damian Conway (damian@conway.org)
 138
 139 =head1 BUGS AND IRRITATIONS
 140
 141 Because it's a module, not an integral part of the interpreter, NEXT.pm
 142 has to guess where the surrounding call was found in the method
 143 look-up sequence. In the presence of diamond inheritance patterns
 144 it occasionally guesses wrong.
 145
 146 It's also too slow (despite caching).
 147
 148 Comment, suggestions, and patches welcome.
 149
 150 =head1 COPYRIGHT
 151
 152  Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
 153  This module is free software. It may be used, redistributed
 154     and/or modified under the same terms as Perl itself.