home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / NEXT.pm < prev    next >
Encoding:
Perl POD Document  |  2002-06-19  |  9.5 KB  |  310 lines
  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.
  310.