| 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. |