| 1 | package NEXT;
|
|---|
| 2 | $VERSION = '0.60';
|
|---|
| 3 | use Carp;
|
|---|
| 4 | use strict;
|
|---|
| 5 |
|
|---|
| 6 | sub NEXT::ELSEWHERE::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 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 |
|
|---|
| 32 | sub AUTOLOAD
|
|---|
| 33 | {
|
|---|
| 34 | my ($self) = @_;
|
|---|
| 35 | my $caller = (caller(1))[3];
|
|---|
| 36 | my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
|
|---|
| 37 | undef $NEXT::AUTOLOAD;
|
|---|
| 38 | my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
|
|---|
| 39 | my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
|
|---|
| 40 | croak "Can't call $wanted from $caller"
|
|---|
| 41 | unless $caller_method eq $wanted_method;
|
|---|
| 42 |
|
|---|
| 43 | local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
|
|---|
| 44 | ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
|
|---|
| 45 |
|
|---|
| 46 |
|
|---|
| 47 | unless ($NEXT::NEXT{$self,$wanted_method}) {
|
|---|
| 48 | my @forebears =
|
|---|
| 49 | NEXT::ELSEWHERE::ancestors ref $self || $self,
|
|---|
| 50 | $wanted_class;
|
|---|
| 51 | while (@forebears) {
|
|---|
| 52 | last if shift @forebears eq $caller_class
|
|---|
| 53 | }
|
|---|
| 54 | no strict 'refs';
|
|---|
| 55 | @{$NEXT::NEXT{$self,$wanted_method}} =
|
|---|
| 56 | map { *{"${_}::$caller_method"}{CODE}||() } @forebears
|
|---|
| 57 | unless $wanted_method eq 'AUTOLOAD';
|
|---|
| 58 | @{$NEXT::NEXT{$self,$wanted_method}} =
|
|---|
| 59 | map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
|
|---|
| 60 | unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
|
|---|
| 61 | $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
|
|---|
| 62 | }
|
|---|
| 63 | my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
|
|---|
| 64 | while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
|
|---|
| 65 | && defined $call_method
|
|---|
| 66 | && $NEXT::SEEN->{$self,$call_method}++) {
|
|---|
| 67 | $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
|
|---|
| 68 | }
|
|---|
| 69 | unless (defined $call_method) {
|
|---|
| 70 | return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
|
|---|
| 71 | (local $Carp::CarpLevel)++;
|
|---|
| 72 | croak qq(Can't locate object method "$wanted_method" ),
|
|---|
| 73 | qq(via package "$caller_class");
|
|---|
| 74 | };
|
|---|
| 75 | return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
|
|---|
| 76 | no strict 'refs';
|
|---|
| 77 | ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
|
|---|
| 78 | if $wanted_method eq 'AUTOLOAD';
|
|---|
| 79 | $$call_method = $caller_class."::NEXT::".$wanted_method;
|
|---|
| 80 | return $call_method->(@_);
|
|---|
| 81 | }
|
|---|
| 82 |
|
|---|
| 83 | no strict 'vars';
|
|---|
| 84 | package NEXT::UNSEEN; @ISA = 'NEXT';
|
|---|
| 85 | package NEXT::DISTINCT; @ISA = 'NEXT';
|
|---|
| 86 | package NEXT::ACTUAL; @ISA = 'NEXT';
|
|---|
| 87 | package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
|
|---|
| 88 | package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
|
|---|
| 89 | package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
|
|---|
| 90 | package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
|
|---|
| 91 |
|
|---|
| 92 | package EVERY::LAST; @ISA = 'EVERY';
|
|---|
| 93 | package EVERY; @ISA = 'NEXT';
|
|---|
| 94 | sub AUTOLOAD
|
|---|
| 95 | {
|
|---|
| 96 | my ($self) = @_;
|
|---|
| 97 | my $caller = (caller(1))[3];
|
|---|
| 98 | my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD';
|
|---|
| 99 | undef $EVERY::AUTOLOAD;
|
|---|
| 100 | my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
|
|---|
| 101 |
|
|---|
| 102 | local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} =
|
|---|
| 103 | $NEXT::ALREADY_IN_EVERY{$self,$wanted_method};
|
|---|
| 104 |
|
|---|
| 105 | return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++;
|
|---|
| 106 |
|
|---|
| 107 | my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
|
|---|
| 108 | $wanted_class;
|
|---|
| 109 | @forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
|
|---|
| 110 | no strict 'refs';
|
|---|
| 111 | my %seen;
|
|---|
| 112 | my @every = map { my $sub = "${_}::$wanted_method";
|
|---|
| 113 | !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
|
|---|
| 114 | } @forebears
|
|---|
| 115 | unless $wanted_method eq 'AUTOLOAD';
|
|---|
| 116 |
|
|---|
| 117 | my $want = wantarray;
|
|---|
| 118 | if (@every) {
|
|---|
| 119 | if ($want) {
|
|---|
| 120 | return map {($_, [$self->$_(@_[1..$#_])])} @every;
|
|---|
| 121 | }
|
|---|
| 122 | elsif (defined $want) {
|
|---|
| 123 | return { map {($_, scalar($self->$_(@_[1..$#_])))}
|
|---|
| 124 | @every
|
|---|
| 125 | };
|
|---|
| 126 | }
|
|---|
| 127 | else {
|
|---|
| 128 | $self->$_(@_[1..$#_]) for @every;
|
|---|
| 129 | return;
|
|---|
| 130 | }
|
|---|
| 131 | }
|
|---|
| 132 |
|
|---|
| 133 | @every = map { my $sub = "${_}::AUTOLOAD";
|
|---|
| 134 | !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
|
|---|
| 135 | } @forebears;
|
|---|
| 136 | if ($want) {
|
|---|
| 137 | return map { $$_ = ref($self)."::EVERY::".$wanted_method;
|
|---|
| 138 | ($_, [$self->$_(@_[1..$#_])]);
|
|---|
| 139 | } @every;
|
|---|
| 140 | }
|
|---|
| 141 | elsif (defined $want) {
|
|---|
| 142 | return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
|
|---|
| 143 | ($_, scalar($self->$_(@_[1..$#_])))
|
|---|
| 144 | } @every
|
|---|
| 145 | };
|
|---|
| 146 | }
|
|---|
| 147 | else {
|
|---|
| 148 | for (@every) {
|
|---|
| 149 | $$_ = ref($self)."::EVERY::".$wanted_method;
|
|---|
| 150 | $self->$_(@_[1..$#_]);
|
|---|
| 151 | }
|
|---|
| 152 | return;
|
|---|
| 153 | }
|
|---|
| 154 | }
|
|---|
| 155 |
|
|---|
| 156 |
|
|---|
| 157 | 1;
|
|---|
| 158 |
|
|---|
| 159 | __END__
|
|---|
| 160 |
|
|---|
| 161 | =head1 NAME
|
|---|
| 162 |
|
|---|
| 163 | NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
|
|---|
| 164 |
|
|---|
| 165 |
|
|---|
| 166 | =head1 SYNOPSIS
|
|---|
| 167 |
|
|---|
| 168 | use NEXT;
|
|---|
| 169 |
|
|---|
| 170 | package A;
|
|---|
| 171 | sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
|
|---|
| 172 | sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
|
|---|
| 173 |
|
|---|
| 174 | package B;
|
|---|
| 175 | use base qw( A );
|
|---|
| 176 | sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
|
|---|
| 177 | sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
|
|---|
| 178 |
|
|---|
| 179 | package C;
|
|---|
| 180 | sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
|
|---|
| 181 | sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
|
|---|
| 182 | sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
|
|---|
| 183 |
|
|---|
| 184 | package D;
|
|---|
| 185 | use base qw( B C );
|
|---|
| 186 | sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
|
|---|
| 187 | sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
|
|---|
| 188 | sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
|
|---|
| 189 |
|
|---|
| 190 | package main;
|
|---|
| 191 |
|
|---|
| 192 | my $obj = bless {}, "D";
|
|---|
| 193 |
|
|---|
| 194 | $obj->method(); # Calls D::method, A::method, C::method
|
|---|
| 195 | $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
|
|---|
| 196 |
|
|---|
| 197 | # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
|
|---|
| 198 |
|
|---|
| 199 |
|
|---|
| 200 |
|
|---|
| 201 | =head1 DESCRIPTION
|
|---|
| 202 |
|
|---|
| 203 | NEXT.pm adds a pseudoclass named C<NEXT> to any program
|
|---|
| 204 | that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
|
|---|
| 205 | C<m> is redispatched as if the calling method had not originally been found.
|
|---|
| 206 |
|
|---|
| 207 | In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
|
|---|
| 208 | left-to-right search of C<$self>'s class hierarchy that resulted in the
|
|---|
| 209 | original call to C<m>.
|
|---|
| 210 |
|
|---|
| 211 | Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
|
|---|
| 212 | begins a new dispatch that is restricted to searching the ancestors
|
|---|
| 213 | of the current class. C<$self-E<gt>NEXT::m()> can backtrack
|
|---|
| 214 | past the current class -- to look for a suitable method in other
|
|---|
| 215 | ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
|
|---|
| 216 |
|
|---|
| 217 | A typical use would be in the destructors of a class hierarchy,
|
|---|
| 218 | as illustrated in the synopsis above. Each class in the hierarchy
|
|---|
| 219 | has a DESTROY method that performs some class-specific action
|
|---|
| 220 | and then redispatches the call up the hierarchy. As a result,
|
|---|
| 221 | when an object of class D is destroyed, the destructors of I<all>
|
|---|
| 222 | its parent classes are called (in depth-first, left-to-right order).
|
|---|
| 223 |
|
|---|
| 224 | Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
|
|---|
| 225 | If such a method determined that it was not able to handle a
|
|---|
| 226 | particular call, it might choose to redispatch that call, in the
|
|---|
| 227 | hope that some other C<AUTOLOAD> (above it, or to its left) might
|
|---|
| 228 | do better.
|
|---|
| 229 |
|
|---|
| 230 | By default, if a redispatch attempt fails to find another method
|
|---|
| 231 | elsewhere in the objects class hierarchy, it quietly gives up and does
|
|---|
| 232 | nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
|
|---|
| 233 | is also unlike the (generally annoying) behaviour of C<SUPER>, which
|
|---|
| 234 | throws an exception if it cannot redispatch.
|
|---|
| 235 |
|
|---|
| 236 | Note that it is a fatal error for any method (including C<AUTOLOAD>)
|
|---|
| 237 | to attempt to redispatch any method that does not have the
|
|---|
| 238 | same name. For example:
|
|---|
| 239 |
|
|---|
| 240 | sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
|
|---|
| 241 |
|
|---|
| 242 |
|
|---|
| 243 | =head2 Enforcing redispatch
|
|---|
| 244 |
|
|---|
| 245 | It is possible to make C<NEXT> redispatch more demandingly (i.e. like
|
|---|
| 246 | C<SUPER> does), so that the redispatch throws an exception if it cannot
|
|---|
| 247 | find a "next" method to call.
|
|---|
| 248 |
|
|---|
| 249 | To do this, simple invoke the redispatch as:
|
|---|
| 250 |
|
|---|
| 251 | $self->NEXT::ACTUAL::method();
|
|---|
| 252 |
|
|---|
| 253 | rather than:
|
|---|
| 254 |
|
|---|
| 255 | $self->NEXT::method();
|
|---|
| 256 |
|
|---|
| 257 | The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
|
|---|
| 258 | or it should throw an exception.
|
|---|
| 259 |
|
|---|
| 260 | C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
|
|---|
| 261 | decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
|
|---|
| 262 | semantics:
|
|---|
| 263 |
|
|---|
| 264 | sub AUTOLOAD {
|
|---|
| 265 | if ($AUTOLOAD =~ /foo|bar/) {
|
|---|
| 266 | # handle here
|
|---|
| 267 | }
|
|---|
| 268 | else { # try elsewhere
|
|---|
| 269 | shift()->NEXT::ACTUAL::AUTOLOAD(@_);
|
|---|
| 270 | }
|
|---|
| 271 | }
|
|---|
| 272 |
|
|---|
| 273 | By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
|
|---|
| 274 | method call, an exception will be thrown (as usually happens in the absence of
|
|---|
| 275 | a suitable C<AUTOLOAD>).
|
|---|
| 276 |
|
|---|
| 277 |
|
|---|
| 278 | =head2 Avoiding repetitions
|
|---|
| 279 |
|
|---|
| 280 | If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
|
|---|
| 281 |
|
|---|
| 282 | # A B
|
|---|
| 283 | # / \ /
|
|---|
| 284 | # C D
|
|---|
| 285 | # \ /
|
|---|
| 286 | # E
|
|---|
| 287 |
|
|---|
| 288 | use NEXT;
|
|---|
|
|---|
