lib/NEXT.pm

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