Commit | Line | Data |
---|---|---|
e4783b1c JH |
1 | package NEXT; |
2 | use Carp; | |
3 | use strict; | |
4 | ||
5 | sub ancestors | |
6 | { | |
7 | my @inlist = @_; | |
8 | my @outlist = (); | |
9 | while (@inlist) { | |
10 | push @outlist, shift @inlist; | |
11 | no strict 'refs'; | |
12 | unshift @inlist, @{"$outlist[-1]::ISA"}; | |
13 | } | |
14 | return @outlist; | |
15 | } | |
16 | ||
17 | sub AUTOLOAD | |
18 | { | |
19 | my ($self) = @_; | |
20 | my $caller = (caller(1))[3]; | |
21 | my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD'; | |
22 | undef $NEXT::AUTOLOAD; | |
23 | my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g; | |
24 | my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g; | |
25 | croak "Can't call $wanted from $caller" | |
26 | unless $caller_method eq $wanted_method; | |
27 | ||
28 | local $NEXT::NEXT{$self,$wanted_method} = | |
29 | $NEXT::NEXT{$self,$wanted_method}; | |
30 | ||
31 | unless (@{$NEXT::NEXT{$self,$wanted_method}||[]}) { | |
32 | my @forebears = ancestors ref $self; | |
33 | while (@forebears) { | |
34 | last if shift @forebears eq $caller_class | |
35 | } | |
36 | no strict 'refs'; | |
37 | @{$NEXT::NEXT{$self,$wanted_method}} = | |
55a1c97c JH |
38 | map { *{"${_}::$caller_method"}{CODE}||() } @forebears |
39 | unless $wanted_method eq 'AUTOLOAD'; | |
e4783b1c | 40 | @{$NEXT::NEXT{$self,$wanted_method}} = |
55a1c97c JH |
41 | map { (*{"${_}::AUTOLOAD"}{CODE}) ? |
42 | "${_}::AUTOLOAD" : () } @forebears | |
43 | unless @{$NEXT::NEXT{$self,$wanted_method}||[]}; | |
44 | } | |
45 | my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; | |
46 | return unless defined $call_method; | |
47 | if (ref $call_method eq 'CODE') { | |
48 | return shift()->$call_method(@_) | |
49 | } | |
50 | else { # AN AUTOLOAD | |
51 | no strict 'refs'; | |
52 | ${$call_method} = $caller_method eq 'AUTOLOAD' && ${"${caller_class}::AUTOLOAD"} || $wanted; | |
53 | return $call_method->(@_); | |
e4783b1c | 54 | } |
e4783b1c JH |
55 | } |
56 | ||
57 | 1; | |
58 | ||
59 | __END__ | |
60 | ||
61 | =head1 NAME | |
62 | ||
63 | NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch | |
64 | ||
65 | ||
66 | =head1 SYNOPSIS | |
67 | ||
68 | use NEXT; | |
69 | ||
70 | package A; | |
71 | sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() } | |
72 | sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() } | |
73 | ||
74 | package B; | |
75 | use base qw( A ); | |
76 | sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } | |
77 | sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() } | |
78 | ||
79 | package C; | |
80 | sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() } | |
81 | sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } | |
82 | sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() } | |
83 | ||
84 | package D; | |
85 | use base qw( B C ); | |
86 | sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() } | |
87 | sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } | |
88 | sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() } | |
89 | ||
90 | package main; | |
91 | ||
92 | my $obj = bless {}, "D"; | |
93 | ||
94 | $obj->method(); # Calls D::method, A::method, C::method | |
95 | $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD | |
96 | ||
97 | # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY | |
98 | ||
99 | ||
100 | =head1 DESCRIPTION | |
101 | ||
102 | NEXT.pm adds a pseudoclass named C<NEXT> to any program | |
103 | that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to | |
104 | C<m> is redispatched as if the calling method had not originally been found. | |
105 | ||
106 | In other words, a call to C<$self->NEXT::m()> resumes the depth-first, | |
55a1c97c JH |
107 | left-to-right search of C<$self>'s class hierarchy that resulted in the |
108 | original call to C<m>. | |
109 | ||
110 | Note that this is not the same thing as C<$self->SUPER::m()>, which | |
111 | begins a new dispatch that is restricted to searching the ancestors | |
112 | of the current class. C<$self->NEXT::m()> can backtrack | |
113 | past the current class -- to look for a suitable method in other | |
114 | ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot. | |
e4783b1c JH |
115 | |
116 | A typical use would be in the destructors of a class hierarchy, | |
117 | as illustrated in the synopsis above. Each class in the hierarchy | |
118 | has a DESTROY method that performs some class-specific action | |
119 | and then redispatches the call up the hierarchy. As a result, | |
120 | when an object of class D is destroyed, the destructors of I<all> | |
121 | its parent classes are called (in depth-first, left-to-right order). | |
122 | ||
123 | Another typical use of redispatch would be in C<AUTOLOAD>'ed methods. | |
124 | If such a method determined that it was not able to handle a | |
125 | particular call, it might choose to redispatch that call, in the | |
126 | hope that some other C<AUTOLOAD> (above it, or to its left) might | |
127 | do better. | |
128 | ||
129 | Note that it is a fatal error for any method (including C<AUTOLOAD>) | |
130 | to attempt to redispatch any method except itself. For example: | |
131 | ||
132 | sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() } | |
133 | ||
134 | ||
135 | =head1 AUTHOR | |
136 | ||
137 | Damian Conway (damian@conway.org) | |
138 | ||
139 | =head1 BUGS AND IRRITATIONS | |
140 | ||
141 | Because it's a module, not an integral part of the interpreter, NEXT.pm | |
142 | has to guess where the surrounding call was found in the method | |
143 | look-up sequence. In the presence of diamond inheritance patterns | |
144 | it occasionally guesses wrong. | |
145 | ||
146 | It's also too slow (despite caching). | |
147 | ||
148 | Comment, suggestions, and patches welcome. | |
149 | ||
150 | =head1 COPYRIGHT | |
151 | ||
55a1c97c | 152 | Copyright (c) 2000-2001, Damian Conway. All Rights Reserved. |
e4783b1c | 153 | This module is free software. It may be used, redistributed |
55a1c97c | 154 | and/or modified under the same terms as Perl itself. |