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}} = |
38 | map { *{"${_}::$caller_method"}{CODE}||() } @forebears; |
39 | @{$NEXT::NEXT{$self,$wanted_method}} = |
40 | map { *{"${_}::AUTOLOAD"}{CODE}||() } @forebears |
41 | unless @{$NEXT::NEXT{$self,$wanted_method}}; |
42 | } |
43 | $wanted_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; |
44 | return shift()->$wanted_method(@_) if $wanted_method; |
45 | return; |
46 | } |
47 | |
48 | 1; |
49 | |
50 | __END__ |
51 | |
52 | =head1 NAME |
53 | |
54 | NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch |
55 | |
56 | |
57 | =head1 SYNOPSIS |
58 | |
59 | use NEXT; |
60 | |
61 | package A; |
62 | sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() } |
63 | sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() } |
64 | |
65 | package B; |
66 | use base qw( A ); |
67 | sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } |
68 | sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() } |
69 | |
70 | package C; |
71 | sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() } |
72 | sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } |
73 | sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() } |
74 | |
75 | package D; |
76 | use base qw( B C ); |
77 | sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() } |
78 | sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } |
79 | sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() } |
80 | |
81 | package main; |
82 | |
83 | my $obj = bless {}, "D"; |
84 | |
85 | $obj->method(); # Calls D::method, A::method, C::method |
86 | $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD |
87 | |
88 | # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY |
89 | |
90 | |
91 | =head1 DESCRIPTION |
92 | |
93 | NEXT.pm adds a pseudoclass named C<NEXT> to any program |
94 | that uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to |
95 | C<m> is redispatched as if the calling method had not originally been found. |
96 | |
97 | In other words, a call to C<$self->NEXT::m()> resumes the depth-first, |
98 | left-to-right search of parent classes that resulted in the original |
99 | call to C<m>. |
100 | |
101 | A typical use would be in the destructors of a class hierarchy, |
102 | as illustrated in the synopsis above. Each class in the hierarchy |
103 | has a DESTROY method that performs some class-specific action |
104 | and then redispatches the call up the hierarchy. As a result, |
105 | when an object of class D is destroyed, the destructors of I<all> |
106 | its parent classes are called (in depth-first, left-to-right order). |
107 | |
108 | Another typical use of redispatch would be in C<AUTOLOAD>'ed methods. |
109 | If such a method determined that it was not able to handle a |
110 | particular call, it might choose to redispatch that call, in the |
111 | hope that some other C<AUTOLOAD> (above it, or to its left) might |
112 | do better. |
113 | |
114 | Note that it is a fatal error for any method (including C<AUTOLOAD>) |
115 | to attempt to redispatch any method except itself. For example: |
116 | |
117 | sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() } |
118 | |
119 | |
120 | =head1 AUTHOR |
121 | |
122 | Damian Conway (damian@conway.org) |
123 | |
124 | =head1 BUGS AND IRRITATIONS |
125 | |
126 | Because it's a module, not an integral part of the interpreter, NEXT.pm |
127 | has to guess where the surrounding call was found in the method |
128 | look-up sequence. In the presence of diamond inheritance patterns |
129 | it occasionally guesses wrong. |
130 | |
131 | It's also too slow (despite caching). |
132 | |
133 | Comment, suggestions, and patches welcome. |
134 | |
135 | =head1 COPYRIGHT |
136 | |
137 | Copyright (c) 2000, Damian Conway. All Rights Reserved. |
138 | This module is free software. It may be used, redistributed |
139 | and/or modified under the terms of the Perl Artistic License |
140 | (see http://www.perl.com/perl/misc/Artistic.html) |