Commit | Line | Data |
---|---|---|
e4783b1c | 1 | package NEXT; |
13021a80 | 2 | $VERSION = '0.50'; |
e4783b1c JH |
3 | use Carp; |
4 | use strict; | |
5 | ||
6 | sub ancestors | |
7 | { | |
13021a80 | 8 | my @inlist = shift; |
e4783b1c | 9 | my @outlist = (); |
13021a80 JH |
10 | while (my $next = shift @inlist) { |
11 | push @outlist, $next; | |
e4783b1c JH |
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 JH |
29 | local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) = |
30 | ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN); | |
e4783b1c | 31 | |
13021a80 JH |
32 | |
33 | unless ($NEXT::NEXT{$self,$wanted_method}) { | |
34 | my @forebears = | |
35 | ancestors ref $self || $self, $wanted_class; | |
e4783b1c JH |
36 | while (@forebears) { |
37 | last if shift @forebears eq $caller_class | |
38 | } | |
39 | no strict 'refs'; | |
40 | @{$NEXT::NEXT{$self,$wanted_method}} = | |
55a1c97c JH |
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 JH |
45 | unless @{$NEXT::NEXT{$self,$wanted_method}||[]}; |
46 | } | |
47 | my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; | |
13021a80 JH |
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 JH |
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 JH |
64 | } |
65 | ||
13021a80 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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 JH |
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. |