I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / NEXT.pm
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.