home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _2d47c11811bfb9430375387a3d353866 < prev    next >
Text File  |  2004-06-01  |  17KB  |  534 lines
  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;
  289.  
  290.     package A;                 
  291.     sub foo { print "called A::foo\n"; shift->NEXT::foo() }
  292.  
  293.     package B;                 
  294.     sub foo { print "called B::foo\n"; shift->NEXT::foo() }
  295.  
  296.     package C; @ISA = qw( A );
  297.     sub foo { print "called C::foo\n"; shift->NEXT::foo() }
  298.  
  299.     package D; @ISA = qw(A B);
  300.     sub foo { print "called D::foo\n"; shift->NEXT::foo() }
  301.  
  302.     package E; @ISA = qw(C D);
  303.     sub foo { print "called E::foo\n"; shift->NEXT::foo() }
  304.  
  305.     E->foo();
  306.  
  307. then derived classes may (re-)inherit base-class methods through two or
  308. more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
  309. through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
  310. will invoke the multiply inherited method as many times as it is
  311. inherited. For example, the above code prints:
  312.  
  313.         called E::foo
  314.         called C::foo
  315.         called A::foo
  316.         called D::foo
  317.         called A::foo
  318.         called B::foo
  319.  
  320. (i.e. C<A::foo> is called twice).
  321.  
  322. In some cases this I<may> be the desired effect within a diamond hierarchy,
  323. but in others (e.g. for destructors) it may be more appropriate to 
  324. call each method only once during a sequence of redispatches.
  325.  
  326. To cover such cases, you can redispatch methods via:
  327.  
  328.         $self->NEXT::DISTINCT::method();
  329.  
  330. rather than:
  331.  
  332.         $self->NEXT::method();
  333.  
  334. This causes the redispatcher to only visit each distinct C<method> method
  335. once. That is, to skip any classes in the hierarchy that it has
  336. already visited during redispatch. So, for example, if the
  337. previous example were rewritten:
  338.  
  339.         package A;                 
  340.         sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
  341.  
  342.         package B;                 
  343.         sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
  344.  
  345.         package C; @ISA = qw( A );
  346.         sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
  347.  
  348.         package D; @ISA = qw(A B);
  349.         sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
  350.  
  351.         package E; @ISA = qw(C D);
  352.         sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
  353.  
  354.         E->foo();
  355.  
  356. then it would print:
  357.         
  358.         called E::foo
  359.         called C::foo
  360.         called A::foo
  361.         called D::foo
  362.         called B::foo
  363.  
  364. and omit the second call to C<A::foo> (since it would not be distinct
  365. from the first call to C<A::foo>).
  366.  
  367. Note that you can also use:
  368.  
  369.         $self->NEXT::DISTINCT::ACTUAL::method();
  370.  
  371. or:
  372.  
  373.         $self->NEXT::ACTUAL::DISTINCT::method();
  374.  
  375. to get both unique invocation I<and> exception-on-failure.
  376.  
  377. Note that, for historical compatibility, you can also use
  378. C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
  379.  
  380.  
  381. =head2 Invoking all versions of a method with a single call
  382.  
  383. Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
  384. Its behaviour is considerably simpler than that of the C<NEXT> family.
  385. A call to:
  386.  
  387.     $obj->EVERY::foo();
  388.  
  389. calls I<every> method named C<foo> that the object in C<$obj> has inherited.
  390. That is:
  391.  
  392.     use NEXT;
  393.  
  394.     package A; @ISA = qw(B D X);
  395.     sub foo { print "A::foo " }
  396.  
  397.     package B; @ISA = qw(D X);
  398.     sub foo { print "B::foo " }
  399.  
  400.     package X; @ISA = qw(D);
  401.     sub foo { print "X::foo " }
  402.  
  403.     package D;
  404.     sub foo { print "D::foo " }
  405.  
  406.     package main;
  407.  
  408.     my $obj = bless {}, 'A';
  409.     $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo
  410.  
  411. Prefixing a method call with C<EVERY::> causes every method in the
  412. object's hierarchy with that name to be invoked. As the above example
  413. illustrates, they are not called in Perl's usual "left-most-depth-first"
  414. order. Instead, they are called "breadth-first-dependency-wise".
  415.  
  416. That means that the inheritance tree of the object is traversed breadth-first
  417. and the resulting order of classes is used as the sequence in which methods
  418. are called. However, that sequence is modified by imposing a rule that the
  419. appropritae method of a derived class must be called before the same method of
  420. any ancestral class. That's why, in the above example, C<X::foo> is called
  421. before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
  422.  
  423. In general, there's no need to worry about the order of calls. They will be
  424. left-to-right, breadth-first, most-derived-first. This works perfectly for
  425. most inherited methods (including destructors), but is inappropriate for
  426. some kinds of methods (such as constructors, cloners, debuggers, and
  427. initializers) where it's more appropriate that the least-derived methods be
  428. called first (as more-derived methods may rely on the behaviour of their
  429. "ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
  430.  
  431.     $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo      
  432.  
  433. you can use the C<EVERY::LAST> pseudo-class:
  434.  
  435.     $obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo      
  436.  
  437. which reverses the order of method call.
  438.  
  439. Whichever version is used, the actual methods are called in the same
  440. context (list, scalar, or void) as the original call via C<EVERY>, and return:
  441.  
  442. =over
  443.  
  444. =item *
  445.  
  446. A hash of array references in list context. Each entry of the hash has the
  447. fully qualified method name as its key and a reference to an array containing
  448. the method's list-context return values as its value.
  449.  
  450. =item *
  451.  
  452. A reference to a hash of scalar values in scalar context. Each entry of the hash has the
  453. fully qualified method name as its key and the method's scalar-context return values as its value.
  454.  
  455. =item *
  456.  
  457. Nothing in void context (obviously).
  458.  
  459. =back
  460.  
  461. =head2 Using C<EVERY> methods
  462.  
  463. The typical way to use an C<EVERY> call is to wrap it in another base
  464. method, that all classes inherit. For example, to ensure that every
  465. destructor an object inherits is actually called (as opposed to just the
  466. left-most-depth-first-est one):
  467.  
  468.         package Base;
  469.         sub DESTROY { $_[0]->EVERY::Destroy }
  470.  
  471.         package Derived1; 
  472.         use base 'Base';
  473.         sub Destroy {...}
  474.  
  475.         package Derived2; 
  476.         use base 'Base', 'Derived1';
  477.         sub Destroy {...}
  478.  
  479. et cetera. Every derived class than needs its own clean-up
  480. behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
  481. which the call to C<EVERY::LAST::Destroy> in the inherited destructor
  482. then correctly picks up.
  483.  
  484. Likewise, to create a class hierarchy in which every initializer inherited by
  485. a new object is invoked:
  486.  
  487.         package Base;
  488.         sub new {
  489.         my ($class, %args) = @_;
  490.         my $obj = bless {}, $class;
  491.         $obj->EVERY::LAST::Init(\%args);
  492.     }
  493.  
  494.         package Derived1; 
  495.         use base 'Base';
  496.         sub Init {
  497.         my ($argsref) = @_;
  498.         ...
  499.     }
  500.  
  501.         package Derived2; 
  502.         use base 'Base', 'Derived1';
  503.         sub Init {
  504.         my ($argsref) = @_;
  505.         ...
  506.     }
  507.  
  508. et cetera. Every derived class than needs some additional initialization
  509. behaviour simply adds its own C<Init> method (I<not> a C<new> method),
  510. which the call to C<EVERY::LAST::Init> in the inherited constructor
  511. then correctly picks up.
  512.  
  513.  
  514. =head1 AUTHOR
  515.  
  516. Damian Conway (damian@conway.org)
  517.  
  518. =head1 BUGS AND IRRITATIONS
  519.  
  520. Because it's a module, not an integral part of the interpreter, NEXT.pm
  521. has to guess where the surrounding call was found in the method
  522. look-up sequence. In the presence of diamond inheritance patterns
  523. it occasionally guesses wrong.
  524.  
  525. It's also too slow (despite caching).
  526.  
  527. Comment, suggestions, and patches welcome.
  528.  
  529. =head1 COPYRIGHT
  530.  
  531.  Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
  532.  This module is free software. It may be used, redistributed
  533.     and/or modified under the same terms as Perl itself.
  534.