Commit | Line | Data |
e4783b1c |
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 |
38 | map { *{"${_}::$caller_method"}{CODE}||() } @forebears |
39 | unless $wanted_method eq 'AUTOLOAD'; |
e4783b1c |
40 | @{$NEXT::NEXT{$self,$wanted_method}} = |
55a1c97c |
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 |
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 |
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 |
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. |