Commit | Line | Data |
---|---|---|
e4783b1c | 1 | package NEXT; |
874ad44d | 2 | $VERSION = '0.60_01'; |
e4783b1c JH |
3 | use Carp; |
4 | use strict; | |
5 | ||
52138ef3 | 6 | sub NEXT::ELSEWHERE::ancestors |
e4783b1c | 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 | ||
bf5734d4 JH |
18 | sub NEXT::ELSEWHERE::ordered_ancestors |
19 | { | |
20 | my @inlist = shift; | |
21 | my @outlist = (); | |
22 | while (my $next = shift @inlist) { | |
23 | push @outlist, $next; | |
24 | no strict 'refs'; | |
25 | push @inlist, @{"$outlist[-1]::ISA"}; | |
26 | } | |
27 | return sort { $a->isa($b) ? -1 | |
28 | : $b->isa($a) ? +1 | |
29 | : 0 } @outlist; | |
30 | } | |
31 | ||
e4783b1c JH |
32 | sub AUTOLOAD |
33 | { | |
34 | my ($self) = @_; | |
874ad44d DR |
35 | my $depth = 1; |
36 | until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ } | |
37 | my $caller = (caller($depth))[3]; | |
e4783b1c JH |
38 | my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD'; |
39 | undef $NEXT::AUTOLOAD; | |
40 | my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g; | |
41 | my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g; | |
42 | croak "Can't call $wanted from $caller" | |
43 | unless $caller_method eq $wanted_method; | |
44 | ||
13021a80 JH |
45 | local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) = |
46 | ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN); | |
e4783b1c | 47 | |
13021a80 JH |
48 | |
49 | unless ($NEXT::NEXT{$self,$wanted_method}) { | |
50 | my @forebears = | |
52138ef3 JH |
51 | NEXT::ELSEWHERE::ancestors ref $self || $self, |
52 | $wanted_class; | |
e4783b1c JH |
53 | while (@forebears) { |
54 | last if shift @forebears eq $caller_class | |
55 | } | |
56 | no strict 'refs'; | |
57 | @{$NEXT::NEXT{$self,$wanted_method}} = | |
55a1c97c JH |
58 | map { *{"${_}::$caller_method"}{CODE}||() } @forebears |
59 | unless $wanted_method eq 'AUTOLOAD'; | |
e4783b1c | 60 | @{$NEXT::NEXT{$self,$wanted_method}} = |
13021a80 | 61 | map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears |
55a1c97c | 62 | unless @{$NEXT::NEXT{$self,$wanted_method}||[]}; |
52138ef3 | 63 | $NEXT::SEEN->{$self,*{$caller}{CODE}}++; |
55a1c97c JH |
64 | } |
65 | my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; | |
bf5734d4 JH |
66 | while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ |
67 | && defined $call_method | |
13021a80 JH |
68 | && $NEXT::SEEN->{$self,$call_method}++) { |
69 | $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; | |
e4783b1c | 70 | } |
13021a80 JH |
71 | unless (defined $call_method) { |
72 | return unless $wanted_class =~ /^NEXT:.*:ACTUAL/; | |
73 | (local $Carp::CarpLevel)++; | |
74 | croak qq(Can't locate object method "$wanted_method" ), | |
75 | qq(via package "$caller_class"); | |
76 | }; | |
52138ef3 | 77 | return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE'; |
13021a80 JH |
78 | no strict 'refs'; |
79 | ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// | |
80 | if $wanted_method eq 'AUTOLOAD'; | |
81 | $$call_method = $caller_class."::NEXT::".$wanted_method; | |
82 | return $call_method->(@_); | |
e4783b1c JH |
83 | } |
84 | ||
13021a80 JH |
85 | no strict 'vars'; |
86 | package NEXT::UNSEEN; @ISA = 'NEXT'; | |
52138ef3 | 87 | package NEXT::DISTINCT; @ISA = 'NEXT'; |
13021a80 JH |
88 | package NEXT::ACTUAL; @ISA = 'NEXT'; |
89 | package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; | |
52138ef3 | 90 | package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; |
13021a80 | 91 | package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; |
52138ef3 | 92 | package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; |
bf5734d4 JH |
93 | |
94 | package EVERY::LAST; @ISA = 'EVERY'; | |
52138ef3 | 95 | package EVERY; @ISA = 'NEXT'; |
bf5734d4 JH |
96 | sub AUTOLOAD |
97 | { | |
98 | my ($self) = @_; | |
874ad44d DR |
99 | my $depth = 1; |
100 | until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ } | |
101 | my $caller = (caller($depth))[3]; | |
bf5734d4 JH |
102 | my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD'; |
103 | undef $EVERY::AUTOLOAD; | |
104 | my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g; | |
105 | ||
106 | local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} = | |
107 | $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}; | |
108 | ||
109 | return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++; | |
110 | ||
111 | my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self, | |
112 | $wanted_class; | |
113 | @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/; | |
114 | no strict 'refs'; | |
115 | my %seen; | |
116 | my @every = map { my $sub = "${_}::$wanted_method"; | |
117 | !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub | |
118 | } @forebears | |
119 | unless $wanted_method eq 'AUTOLOAD'; | |
120 | ||
121 | my $want = wantarray; | |
122 | if (@every) { | |
123 | if ($want) { | |
124 | return map {($_, [$self->$_(@_[1..$#_])])} @every; | |
125 | } | |
126 | elsif (defined $want) { | |
127 | return { map {($_, scalar($self->$_(@_[1..$#_])))} | |
128 | @every | |
129 | }; | |
130 | } | |
131 | else { | |
132 | $self->$_(@_[1..$#_]) for @every; | |
133 | return; | |
134 | } | |
135 | } | |
136 | ||
137 | @every = map { my $sub = "${_}::AUTOLOAD"; | |
138 | !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD" | |
139 | } @forebears; | |
140 | if ($want) { | |
141 | return map { $$_ = ref($self)."::EVERY::".$wanted_method; | |
142 | ($_, [$self->$_(@_[1..$#_])]); | |
143 | } @every; | |
144 | } | |
145 | elsif (defined $want) { | |
146 | return { map { $$_ = ref($self)."::EVERY::".$wanted_method; | |
147 | ($_, scalar($self->$_(@_[1..$#_]))) | |
148 | } @every | |
149 | }; | |
150 | } | |
151 | else { | |
152 | for (@every) { | |
153 | $$_ = ref($self)."::EVERY::".$wanted_method; | |
154 | $self->$_(@_[1..$#_]); | |
155 | } | |
156 | return; | |
157 | } | |
158 | } | |
159 | ||
13021a80 | 160 | |
e4783b1c JH |
161 | 1; |
162 | ||
163 | __END__ | |
164 | ||
165 | =head1 NAME | |
166 | ||
bf5734d4 | 167 | NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch |
e4783b1c JH |
168 | |
169 | ||
170 | =head1 SYNOPSIS | |
171 | ||
13021a80 | 172 | use NEXT; |
e4783b1c | 173 | |
13021a80 JH |
174 | package A; |
175 | sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() } | |
176 | sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() } | |
e4783b1c | 177 | |
13021a80 JH |
178 | package B; |
179 | use base qw( A ); | |
180 | sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } | |
181 | sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() } | |
e4783b1c | 182 | |
13021a80 JH |
183 | package C; |
184 | sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() } | |
185 | sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } | |
186 | sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() } | |
e4783b1c | 187 | |
13021a80 JH |
188 | package D; |
189 | use base qw( B C ); | |
190 | sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() } | |
191 | sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } | |
192 | sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() } | |
e4783b1c | 193 | |
13021a80 | 194 | package main; |
e4783b1c | 195 | |
13021a80 | 196 | my $obj = bless {}, "D"; |
e4783b1c | 197 | |
13021a80 JH |
198 | $obj->method(); # Calls D::method, A::method, C::method |
199 | $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD | |
e4783b1c | 200 | |
13021a80 | 201 | # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY |
e4783b1c JH |
202 | |
203 | ||
bf5734d4 | 204 | |
e4783b1c JH |
205 | =head1 DESCRIPTION |
206 | ||
207 | NEXT.pm adds a pseudoclass named C<NEXT> to any program | |
e23eab12 | 208 | that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to |
e4783b1c JH |
209 | C<m> is redispatched as if the calling method had not originally been found. |
210 | ||
e23eab12 | 211 | In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first, |
55a1c97c JH |
212 | left-to-right search of C<$self>'s class hierarchy that resulted in the |
213 | original call to C<m>. | |
214 | ||
e23eab12 | 215 | Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which |
55a1c97c | 216 | begins a new dispatch that is restricted to searching the ancestors |
e23eab12 | 217 | of the current class. C<$self-E<gt>NEXT::m()> can backtrack |
55a1c97c | 218 | past the current class -- to look for a suitable method in other |
e23eab12 | 219 | ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot. |
e4783b1c JH |
220 | |
221 | A typical use would be in the destructors of a class hierarchy, | |
222 | as illustrated in the synopsis above. Each class in the hierarchy | |
223 | has a DESTROY method that performs some class-specific action | |
224 | and then redispatches the call up the hierarchy. As a result, | |
225 | when an object of class D is destroyed, the destructors of I<all> | |
226 | its parent classes are called (in depth-first, left-to-right order). | |
227 | ||
228 | Another typical use of redispatch would be in C<AUTOLOAD>'ed methods. | |
229 | If such a method determined that it was not able to handle a | |
230 | particular call, it might choose to redispatch that call, in the | |
231 | hope that some other C<AUTOLOAD> (above it, or to its left) might | |
232 | do better. | |
233 | ||
13021a80 JH |
234 | By default, if a redispatch attempt fails to find another method |
235 | elsewhere in the objects class hierarchy, it quietly gives up and does | |
3c4b39be | 236 | nothing (but see L<"Enforcing redispatch">). This gracious acquiescence |
13021a80 JH |
237 | is also unlike the (generally annoying) behaviour of C<SUPER>, which |
238 | throws an exception if it cannot redispatch. | |
239 | ||
e4783b1c | 240 | Note that it is a fatal error for any method (including C<AUTOLOAD>) |
13021a80 JH |
241 | to attempt to redispatch any method that does not have the |
242 | same name. For example: | |
243 | ||
244 | sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() } | |
245 | ||
246 | ||
247 | =head2 Enforcing redispatch | |
248 | ||
249 | It is possible to make C<NEXT> redispatch more demandingly (i.e. like | |
250 | C<SUPER> does), so that the redispatch throws an exception if it cannot | |
251 | find a "next" method to call. | |
252 | ||
253 | To do this, simple invoke the redispatch as: | |
254 | ||
255 | $self->NEXT::ACTUAL::method(); | |
256 | ||
257 | rather than: | |
258 | ||
259 | $self->NEXT::method(); | |
260 | ||
261 | The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call, | |
262 | or it should throw an exception. | |
263 | ||
264 | C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to | |
265 | decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure | |
266 | semantics: | |
267 | ||
268 | sub AUTOLOAD { | |
269 | if ($AUTOLOAD =~ /foo|bar/) { | |
270 | # handle here | |
271 | } | |
272 | else { # try elsewhere | |
273 | shift()->NEXT::ACTUAL::AUTOLOAD(@_); | |
274 | } | |
275 | } | |
276 | ||
277 | By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the | |
278 | method call, an exception will be thrown (as usually happens in the absence of | |
279 | a suitable C<AUTOLOAD>). | |
280 | ||
281 | ||
282 | =head2 Avoiding repetitions | |
283 | ||
284 | If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy: | |
285 | ||
286 | # A B | |
287 | # / \ / | |
288 | # C D | |
289 | # \ / | |
290 | # E | |
291 | ||
292 | use NEXT; | |
293 | ||
294 | package A; | |
295 | sub foo { print "called A::foo\n"; shift->NEXT::foo() } | |
296 | ||
297 | package B; | |
298 | sub foo { print "called B::foo\n"; shift->NEXT::foo() } | |
299 | ||
300 | package C; @ISA = qw( A ); | |
301 | sub foo { print "called C::foo\n"; shift->NEXT::foo() } | |
302 | ||
303 | package D; @ISA = qw(A B); | |
304 | sub foo { print "called D::foo\n"; shift->NEXT::foo() } | |
305 | ||
306 | package E; @ISA = qw(C D); | |
307 | sub foo { print "called E::foo\n"; shift->NEXT::foo() } | |
308 | ||
309 | E->foo(); | |
310 | ||
311 | then derived classes may (re-)inherit base-class methods through two or | |
312 | more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice -- | |
313 | through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches | |
314 | will invoke the multiply inherited method as many times as it is | |
315 | inherited. For example, the above code prints: | |
316 | ||
317 | called E::foo | |
318 | called C::foo | |
319 | called A::foo | |
320 | called D::foo | |
321 | called A::foo | |
322 | called B::foo | |
323 | ||
324 | (i.e. C<A::foo> is called twice). | |
325 | ||
326 | In some cases this I<may> be the desired effect within a diamond hierarchy, | |
327 | but in others (e.g. for destructors) it may be more appropriate to | |
328 | call each method only once during a sequence of redispatches. | |
329 | ||
330 | To cover such cases, you can redispatch methods via: | |
331 | ||
52138ef3 | 332 | $self->NEXT::DISTINCT::method(); |
13021a80 JH |
333 | |
334 | rather than: | |
335 | ||
336 | $self->NEXT::method(); | |
337 | ||
52138ef3 JH |
338 | This causes the redispatcher to only visit each distinct C<method> method |
339 | once. That is, to skip any classes in the hierarchy that it has | |
340 | already visited during redispatch. So, for example, if the | |
13021a80 JH |
341 | previous example were rewritten: |
342 | ||
343 | package A; | |
52138ef3 | 344 | sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() } |
13021a80 JH |
345 | |
346 | package B; | |
52138ef3 | 347 | sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() } |
13021a80 JH |
348 | |
349 | package C; @ISA = qw( A ); | |
52138ef3 | 350 | sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() } |
13021a80 JH |
351 | |
352 | package D; @ISA = qw(A B); | |
52138ef3 | 353 | sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() } |
13021a80 JH |
354 | |
355 | package E; @ISA = qw(C D); | |
52138ef3 | 356 | sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() } |
13021a80 JH |
357 | |
358 | E->foo(); | |
359 | ||
360 | then it would print: | |
361 | ||
362 | called E::foo | |
363 | called C::foo | |
364 | called A::foo | |
365 | called D::foo | |
366 | called B::foo | |
367 | ||
52138ef3 JH |
368 | and omit the second call to C<A::foo> (since it would not be distinct |
369 | from the first call to C<A::foo>). | |
13021a80 JH |
370 | |
371 | Note that you can also use: | |
372 | ||
52138ef3 | 373 | $self->NEXT::DISTINCT::ACTUAL::method(); |
13021a80 JH |
374 | |
375 | or: | |
376 | ||
52138ef3 | 377 | $self->NEXT::ACTUAL::DISTINCT::method(); |
e4783b1c | 378 | |
13021a80 | 379 | to get both unique invocation I<and> exception-on-failure. |
e4783b1c | 380 | |
52138ef3 JH |
381 | Note that, for historical compatibility, you can also use |
382 | C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>. | |
e4783b1c | 383 | |
bf5734d4 JH |
384 | |
385 | =head2 Invoking all versions of a method with a single call | |
386 | ||
387 | Yet another pseudo-class that NEXT.pm provides is C<EVERY>. | |
388 | Its behaviour is considerably simpler than that of the C<NEXT> family. | |
389 | A call to: | |
390 | ||
391 | $obj->EVERY::foo(); | |
392 | ||
393 | calls I<every> method named C<foo> that the object in C<$obj> has inherited. | |
394 | That is: | |
395 | ||
396 | use NEXT; | |
397 | ||
398 | package A; @ISA = qw(B D X); | |
399 | sub foo { print "A::foo " } | |
400 | ||
401 | package B; @ISA = qw(D X); | |
402 | sub foo { print "B::foo " } | |
403 | ||
404 | package X; @ISA = qw(D); | |
405 | sub foo { print "X::foo " } | |
406 | ||
407 | package D; | |
408 | sub foo { print "D::foo " } | |
409 | ||
410 | package main; | |
411 | ||
412 | my $obj = bless {}, 'A'; | |
413 | $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo | |
414 | ||
415 | Prefixing a method call with C<EVERY::> causes every method in the | |
416 | object's hierarchy with that name to be invoked. As the above example | |
417 | illustrates, they are not called in Perl's usual "left-most-depth-first" | |
418 | order. Instead, they are called "breadth-first-dependency-wise". | |
419 | ||
420 | That means that the inheritance tree of the object is traversed breadth-first | |
421 | and the resulting order of classes is used as the sequence in which methods | |
422 | are called. However, that sequence is modified by imposing a rule that the | |
3c4b39be | 423 | appropriate method of a derived class must be called before the same method of |
bf5734d4 JH |
424 | any ancestral class. That's why, in the above example, C<X::foo> is called |
425 | before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>. | |
426 | ||
427 | In general, there's no need to worry about the order of calls. They will be | |
428 | left-to-right, breadth-first, most-derived-first. This works perfectly for | |
429 | most inherited methods (including destructors), but is inappropriate for | |
430 | some kinds of methods (such as constructors, cloners, debuggers, and | |
431 | initializers) where it's more appropriate that the least-derived methods be | |
432 | called first (as more-derived methods may rely on the behaviour of their | |
433 | "ancestors"). In that case, instead of using the C<EVERY> pseudo-class: | |
434 | ||
435 | $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo | |
436 | ||
437 | you can use the C<EVERY::LAST> pseudo-class: | |
438 | ||
439 | $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo | |
440 | ||
441 | which reverses the order of method call. | |
442 | ||
443 | Whichever version is used, the actual methods are called in the same | |
444 | context (list, scalar, or void) as the original call via C<EVERY>, and return: | |
445 | ||
446 | =over | |
447 | ||
448 | =item * | |
449 | ||
450 | A hash of array references in list context. Each entry of the hash has the | |
451 | fully qualified method name as its key and a reference to an array containing | |
452 | the method's list-context return values as its value. | |
453 | ||
454 | =item * | |
455 | ||
456 | A reference to a hash of scalar values in scalar context. Each entry of the hash has the | |
457 | fully qualified method name as its key and the method's scalar-context return values as its value. | |
458 | ||
459 | =item * | |
460 | ||
461 | Nothing in void context (obviously). | |
462 | ||
463 | =back | |
464 | ||
465 | =head2 Using C<EVERY> methods | |
466 | ||
467 | The typical way to use an C<EVERY> call is to wrap it in another base | |
468 | method, that all classes inherit. For example, to ensure that every | |
469 | destructor an object inherits is actually called (as opposed to just the | |
470 | left-most-depth-first-est one): | |
471 | ||
472 | package Base; | |
473 | sub DESTROY { $_[0]->EVERY::Destroy } | |
474 | ||
475 | package Derived1; | |
476 | use base 'Base'; | |
477 | sub Destroy {...} | |
478 | ||
479 | package Derived2; | |
480 | use base 'Base', 'Derived1'; | |
481 | sub Destroy {...} | |
482 | ||
483 | et cetera. Every derived class than needs its own clean-up | |
484 | behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method), | |
485 | which the call to C<EVERY::LAST::Destroy> in the inherited destructor | |
486 | then correctly picks up. | |
487 | ||
488 | Likewise, to create a class hierarchy in which every initializer inherited by | |
489 | a new object is invoked: | |
490 | ||
491 | package Base; | |
492 | sub new { | |
493 | my ($class, %args) = @_; | |
494 | my $obj = bless {}, $class; | |
495 | $obj->EVERY::LAST::Init(\%args); | |
496 | } | |
497 | ||
498 | package Derived1; | |
499 | use base 'Base'; | |
500 | sub Init { | |
501 | my ($argsref) = @_; | |
502 | ... | |
503 | } | |
504 | ||
505 | package Derived2; | |
506 | use base 'Base', 'Derived1'; | |
507 | sub Init { | |
508 | my ($argsref) = @_; | |
509 | ... | |
510 | } | |
511 | ||
512 | et cetera. Every derived class than needs some additional initialization | |
513 | behaviour simply adds its own C<Init> method (I<not> a C<new> method), | |
514 | which the call to C<EVERY::LAST::Init> in the inherited constructor | |
515 | then correctly picks up. | |
516 | ||
517 | ||
e4783b1c JH |
518 | =head1 AUTHOR |
519 | ||
520 | Damian Conway (damian@conway.org) | |
521 | ||
522 | =head1 BUGS AND IRRITATIONS | |
523 | ||
524 | Because it's a module, not an integral part of the interpreter, NEXT.pm | |
525 | has to guess where the surrounding call was found in the method | |
526 | look-up sequence. In the presence of diamond inheritance patterns | |
527 | it occasionally guesses wrong. | |
528 | ||
529 | It's also too slow (despite caching). | |
530 | ||
531 | Comment, suggestions, and patches welcome. | |
532 | ||
533 | =head1 COPYRIGHT | |
534 | ||
55a1c97c | 535 | Copyright (c) 2000-2001, Damian Conway. All Rights Reserved. |
e4783b1c | 536 | This module is free software. It may be used, redistributed |
55a1c97c | 537 | and/or modified under the same terms as Perl itself. |