Commit | Line | Data |
e4783b1c |
1 | package NEXT; |
13021a80 |
2 | $VERSION = '0.50'; |
e4783b1c |
3 | use Carp; |
4 | use strict; |
5 | |
6 | sub ancestors |
7 | { |
13021a80 |
8 | my @inlist = shift; |
e4783b1c |
9 | my @outlist = (); |
13021a80 |
10 | while (my $next = shift @inlist) { |
11 | push @outlist, $next; |
e4783b1c |
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 | |
13021a80 |
29 | local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) = |
30 | ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN); |
e4783b1c |
31 | |
13021a80 |
32 | |
33 | unless ($NEXT::NEXT{$self,$wanted_method}) { |
34 | my @forebears = |
35 | ancestors ref $self || $self, $wanted_class; |
e4783b1c |
36 | while (@forebears) { |
37 | last if shift @forebears eq $caller_class |
38 | } |
39 | no strict 'refs'; |
40 | @{$NEXT::NEXT{$self,$wanted_method}} = |
55a1c97c |
41 | map { *{"${_}::$caller_method"}{CODE}||() } @forebears |
42 | unless $wanted_method eq 'AUTOLOAD'; |
e4783b1c |
43 | @{$NEXT::NEXT{$self,$wanted_method}} = |
13021a80 |
44 | map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears |
55a1c97c |
45 | unless @{$NEXT::NEXT{$self,$wanted_method}||[]}; |
46 | } |
47 | my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; |
13021a80 |
48 | while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method |
49 | && $NEXT::SEEN->{$self,$call_method}++) { |
50 | $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; |
e4783b1c |
51 | } |
13021a80 |
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->(@_); |
e4783b1c |
64 | } |
65 | |
13021a80 |
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 | |
e4783b1c |
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 | |
13021a80 |
83 | use NEXT; |
e4783b1c |
84 | |
13021a80 |
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() } |
e4783b1c |
88 | |
13021a80 |
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() } |
e4783b1c |
93 | |
13021a80 |
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() } |
e4783b1c |
98 | |
13021a80 |
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() } |
e4783b1c |
104 | |
13021a80 |
105 | package main; |
e4783b1c |
106 | |
13021a80 |
107 | my $obj = bless {}, "D"; |
e4783b1c |
108 | |
13021a80 |
109 | $obj->method(); # Calls D::method, A::method, C::method |
110 | $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD |
e4783b1c |
111 | |
13021a80 |
112 | # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY |
e4783b1c |
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, |
55a1c97c |
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. |
e4783b1c |
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 | |
13021a80 |
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 | |
e4783b1c |
150 | Note that it is a fatal error for any method (including C<AUTOLOAD>) |
13021a80 |
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(); |
e4783b1c |
286 | |
13021a80 |
287 | to get both unique invocation I<and> exception-on-failure. |
e4783b1c |
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 | |
55a1c97c |
307 | Copyright (c) 2000-2001, Damian Conway. All Rights Reserved. |
e4783b1c |
308 | This module is free software. It may be used, redistributed |
55a1c97c |
309 | and/or modified under the same terms as Perl itself. |