lib/NEXT.pm

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