lib/NEXT.pm

   1 package NEXT;
   2 $VERSION = '0.51';
   3 use Carp;
   4 use strict;
   5
   6 sub 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 AUTOLOAD
  19 {
  20         my ($self) = @_;
  21         my $caller = (caller(1))[3];
  22         my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
  23         undef $NEXT::AUTOLOAD;
  24         my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
  25         my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
  26         croak "Can't call $wanted from $caller"
  27                 unless $caller_method eq $wanted_method;
  28
  29         local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
  30               ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
  31
  32
  33         unless ($NEXT::NEXT{$self,$wanted_method}) {
  34                 my @forebears =
  35                         ancestors ref $self || $self, $wanted_class;
  36                 while (@forebears) {
  37                         last if shift @forebears eq $caller_class
  38                 }
  39                 no strict 'refs';
  40                 @{$NEXT::NEXT{$self,$wanted_method}} =
  41                         map { *{"${_}::$caller_method"}{CODE}||() } @forebears
  42                                 unless $wanted_method eq 'AUTOLOAD';
  43                 @{$NEXT::NEXT{$self,$wanted_method}} =
  44                         map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
  45                                 unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
  46               $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
  47         }
  48         my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
  49         while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
  50                && $NEXT::SEEN->{$self,$call_method}++) {
  51                 $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
  52         }
  53         unless (defined $call_method) {
  54                 return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
  55                 (local $Carp::CarpLevel)++;
  56                 croak qq(Can't locate object method "$wanted_method" ),
  57                       qq(via package "$caller_class");
  58         };
  59         return shift()->$call_method(@_) if ref $call_method eq 'CODE';
  60         no strict 'refs';
  61         ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
  62                 if $wanted_method eq 'AUTOLOAD';
  63         $$call_method = $caller_class."::NEXT::".$wanted_method;
  64         return $call_method->(@_);
  65 }
  66
  67 no strict 'vars';
  68 package NEXT::UNSEEN;           @ISA = 'NEXT';
  69 package NEXT::ACTUAL;           @ISA = 'NEXT';
  70 package NEXT::ACTUAL::UNSEEN;   @ISA = 'NEXT';
  71 package NEXT::UNSEEN::ACTUAL;   @ISA = 'NEXT';
  72
  73 1;
  74
  75 __END__
  76
  77 =head1 NAME
  78
  79 NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch
  80
  81
  82 =head1 SYNOPSIS
  83
  84     use NEXT;
  85
  86     package A;
  87     sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
  88     sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
  89
  90     package B;
  91     use base qw( A );
  92     sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  93     sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
  94
  95     package C;
  96     sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
  97     sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  98     sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }
  99
 100     package D;
 101     use base qw( B C );
 102     sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
 103     sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
 104     sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }
 105
 106     package main;
 107
 108     my $obj = bless {}, "D";
 109
 110     $obj->method();             # Calls D::method, A::method, C::method
 111     $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
 112
 113     # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
 114
 115
 116 =head1 DESCRIPTION
 117
 118 NEXT.pm adds a pseudoclass named C<NEXT> to any program
 119 that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to
 120 C<m> is redispatched as if the calling method had not originally been found.
 121
 122 In other words, a call to C<$self->NEXT::m()> resumes the depth-first,
 123 left-to-right search of C<$self>'s class hierarchy that resulted in the
 124 original call to C<m>.
 125
 126 Note that this is not the same thing as C<$self->SUPER::m()>, which
 127 begins a new dispatch that is restricted to searching the ancestors
 128 of the current class. C<$self->NEXT::m()> can backtrack
 129 past the current class -- to look for a suitable method in other
 130 ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot.
 131
 132 A typical use would be in the destructors of a class hierarchy,
 133 as illustrated in the synopsis above. Each class in the hierarchy
 134 has a DESTROY method that performs some class-specific action
 135 and then redispatches the call up the hierarchy. As a result,
 136 when an object of class D is destroyed, the destructors of I<all>
 137 its parent classes are called (in depth-first, left-to-right order).
 138
 139 Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
 140 If such a method determined that it was not able to handle a
 141 particular call, it might choose to redispatch that call, in the
 142 hope that some other C<AUTOLOAD> (above it, or to its left) might
 143 do better.
 144
 145 By default, if a redispatch attempt fails to find another method
 146 elsewhere in the objects class hierarchy, it quietly gives up and does
 147 nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
 148 is also unlike the (generally annoying) behaviour of C<SUPER>, which
 149 throws an exception if it cannot redispatch.
 150
 151 Note that it is a fatal error for any method (including C<AUTOLOAD>)
 152 to attempt to redispatch any method that does not have the
 153 same name. For example:
 154
 155         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
 156
 157
 158 =head2 Enforcing redispatch
 159
 160 It is possible to make C<NEXT> redispatch more demandingly (i.e. like
 161 C<SUPER> does), so that the redispatch throws an exception if it cannot
 162 find a "next" method to call.
 163
 164 To do this, simple invoke the redispatch as:
 165
 166         $self->NEXT::ACTUAL::method();
 167
 168 rather than:
 169
 170         $self->NEXT::method();
 171
 172 The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
 173 or it should throw an exception.
 174
 175 C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
 176 decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
 177 semantics:
 178
 179         sub AUTOLOAD {
 180                 if ($AUTOLOAD =~ /foo|bar/) {
 181                         # handle here
 182                 }
 183                 else {  # try elsewhere
 184                         shift()->NEXT::ACTUAL::AUTOLOAD(@_);
 185                 }
 186         }
 187
 188 By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
 189 method call, an exception will be thrown (as usually happens in the absence of
 190 a suitable C<AUTOLOAD>).
 191
 192
 193 =head2 Avoiding repetitions
 194
 195 If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
 196
 197         #     A   B
 198         #    / \ /
 199         #   C   D
 200         #    \ /
 201         #     E
 202
 203         use NEXT;
 204
 205         package A;
 206         sub foo { print "called A::foo\n"; shift->NEXT::foo() }
 207
 208         package B;
 209         sub foo { print "called B::foo\n"; shift->NEXT::foo() }
 210
 211         package C; @ISA = qw( A );
 212         sub foo { print "called C::foo\n"; shift->NEXT::foo() }
 213
 214         package D; @ISA = qw(A B);
 215         sub foo { print "called D::foo\n"; shift->NEXT::foo() }
 216
 217         package E; @ISA = qw(C D);
 218         sub foo { print "called E::foo\n"; shift->NEXT::foo() }
 219
 220         E->foo();
 221
 222 then derived classes may (re-)inherit base-class methods through two or
 223 more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
 224 through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
 225 will invoke the multiply inherited method as many times as it is
 226 inherited. For example, the above code prints:
 227
 228         called E::foo
 229         called C::foo
 230         called A::foo
 231         called D::foo
 232         called A::foo
 233         called B::foo
 234
 235 (i.e. C<A::foo> is called twice).
 236
 237 In some cases this I<may> be the desired effect within a diamond hierarchy,
 238 but in others (e.g. for destructors) it may be more appropriate to
 239 call each method only once during a sequence of redispatches.
 240
 241 To cover such cases, you can redispatch methods via:
 242
 243         $self->NEXT::UNSEEN::method();
 244
 245 rather than:
 246
 247         $self->NEXT::method();
 248
 249 This causes the redispatcher to skip any classes in the hierarchy that it has
 250 already visited in an earlier redispatch. So, for example, if the
 251 previous example were rewritten:
 252
 253         package A;
 254         sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
 255
 256         package B;
 257         sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
 258
 259         package C; @ISA = qw( A );
 260         sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
 261
 262         package D; @ISA = qw(A B);
 263         sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
 264
 265         package E; @ISA = qw(C D);
 266         sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::foo() }
 267
 268         E->foo();
 269
 270 then it would print:
 271
 272         called E::foo
 273         called C::foo
 274         called A::foo
 275         called D::foo
 276         called B::foo
 277
 278 and omit the second call to C<A::foo>.
 279
 280 Note that you can also use:
 281
 282         $self->NEXT::UNSEEN::ACTUAL::method();
 283
 284 or:
 285
 286         $self->NEXT::ACTUAL::UNSEEN::method();
 287
 288 to get both unique invocation I<and> exception-on-failure.
 289
 290
 291 =head1 AUTHOR
 292
 293 Damian Conway (damian@conway.org)
 294
 295 =head1 BUGS AND IRRITATIONS
 296
 297 Because it's a module, not an integral part of the interpreter, NEXT.pm
 298 has to guess where the surrounding call was found in the method
 299 look-up sequence. In the presence of diamond inheritance patterns
 300 it occasionally guesses wrong.
 301
 302 It's also too slow (despite caching).
 303
 304 Comment, suggestions, and patches welcome.
 305
 306 =head1 COPYRIGHT
 307
 308  Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
 309  This module is free software. It may be used, redistributed
 310     and/or modified under the same terms as Perl itself.