diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-09-13 16:44:27 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-09-13 16:44:27 +0100 |
commit | 92d4c6331040f899673234f65d5ab2a406c5a32d (patch) | |
tree | 124180229cd829acfd40143a8add576d5f18a571 /lib | |
parent | 00c2f0c97c1956309eb5a69763c48663bca3a767 (diff) | |
download | perl-92d4c6331040f899673234f65d5ab2a406c5a32d.tar.gz |
Move NEXT from lib to ext.
Diffstat (limited to 'lib')
-rw-r--r-- | lib/.gitignore | 1 | ||||
-rw-r--r-- | lib/NEXT.pm | 563 | ||||
-rw-r--r-- | lib/NEXT/Changes | 60 | ||||
-rw-r--r-- | lib/NEXT/README | 57 | ||||
-rw-r--r-- | lib/NEXT/t/actual.t | 44 | ||||
-rw-r--r-- | lib/NEXT/t/actuns.t | 38 | ||||
-rw-r--r-- | lib/NEXT/t/dynamically_scoped_regex_vars.t | 50 | ||||
-rw-r--r-- | lib/NEXT/t/next.t | 114 | ||||
-rw-r--r-- | lib/NEXT/t/stringify.t | 35 | ||||
-rw-r--r-- | lib/NEXT/t/unseen.t | 54 |
10 files changed, 1 insertions, 1015 deletions
diff --git a/lib/.gitignore b/lib/.gitignore index 9980d736e8..ec42bb5ddf 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -256,6 +256,7 @@ /Module/Pluggable /Module/Pluggable.pm /NDBM_File.pm +/NEXT.pm /Net /Net/Cmd.pm /Net/Config.pm diff --git a/lib/NEXT.pm b/lib/NEXT.pm deleted file mode 100644 index 1e59280241..0000000000 --- a/lib/NEXT.pm +++ /dev/null @@ -1,563 +0,0 @@ -package NEXT; -$VERSION = '0.64'; -use Carp; -use strict; -use overload (); - -sub NEXT::ELSEWHERE::ancestors -{ - my @inlist = shift; - my @outlist = (); - while (my $next = shift @inlist) { - push @outlist, $next; - no strict 'refs'; - unshift @inlist, @{"$outlist[-1]::ISA"}; - } - return @outlist; -} - -sub NEXT::ELSEWHERE::ordered_ancestors -{ - my @inlist = shift; - my @outlist = (); - while (my $next = shift @inlist) { - push @outlist, $next; - no strict 'refs'; - push @inlist, @{"$outlist[-1]::ISA"}; - } - return sort { $a->isa($b) ? -1 - : $b->isa($a) ? +1 - : 0 } @outlist; -} - -sub NEXT::ELSEWHERE::buildAUTOLOAD -{ - my $autoload_name = caller() . '::AUTOLOAD'; - - no strict 'refs'; - *{$autoload_name} = sub { - my ($self) = @_; - my $depth = 1; - until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ } - my $caller = (caller($depth))[3]; - my $wanted = $NEXT::AUTOLOAD || $autoload_name; - undef $NEXT::AUTOLOAD; - my ($caller_class, $caller_method) = do { $caller =~ m{(.*)::(.*)}g }; - my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g }; - croak "Can't call $wanted from $caller" - unless $caller_method eq $wanted_method; - - my $key = ref $self && overload::Overloaded($self) - ? overload::StrVal($self) : $self; - - local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) = - ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN); - - unless ($NEXT::NEXT{$key,$wanted_method}) { - my @forebears = - NEXT::ELSEWHERE::ancestors ref $self || $self, - $wanted_class; - while (@forebears) { - last if shift @forebears eq $caller_class - } - no strict 'refs'; - @{$NEXT::NEXT{$key,$wanted_method}} = - map { - my $stash = \%{"${_}::"}; - ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE})) - ? *{$stash->{$caller_method}}{CODE} - : () } @forebears - unless $wanted_method eq 'AUTOLOAD'; - @{$NEXT::NEXT{$key,$wanted_method}} = - map { - my $stash = \%{"${_}::"}; - ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE})) - ? "${_}::AUTOLOAD" - : () } @forebears - unless @{$NEXT::NEXT{$key,$wanted_method}||[]}; - $NEXT::SEEN->{$key,*{$caller}{CODE}}++; - } - my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}}; - while (do { $wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ } - && defined $call_method - && $NEXT::SEEN->{$key,$call_method}++) { - $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}}; - } - unless (defined $call_method) { - return unless do { $wanted_class =~ /^NEXT:.*:ACTUAL/ }; - (local $Carp::CarpLevel)++; - croak qq(Can't locate object method "$wanted_method" ), - qq(via package "$caller_class"); - }; - return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE'; - no strict 'refs'; - do { ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// } - if $wanted_method eq 'AUTOLOAD'; - $$call_method = $caller_class."::NEXT::".$wanted_method; - return $call_method->(@_); - }; -} - -no strict 'vars'; -package NEXT; NEXT::ELSEWHERE::buildAUTOLOAD(); -package NEXT::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); -package NEXT::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); -package NEXT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); -package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); -package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); -package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); -package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); - -package EVERY; - -sub EVERY::ELSEWHERE::buildAUTOLOAD { - my $autoload_name = caller() . '::AUTOLOAD'; - - no strict 'refs'; - *{$autoload_name} = sub { - my ($self) = @_; - my $depth = 1; - until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ } - my $caller = (caller($depth))[3]; - my $wanted = $EVERY::AUTOLOAD || $autoload_name; - undef $EVERY::AUTOLOAD; - my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g }; - - my $key = ref($self) && overload::Overloaded($self) - ? overload::StrVal($self) : $self; - - local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} = - $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}; - - return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++; - - my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self, - $wanted_class; - @forebears = reverse @forebears if do { $wanted_class =~ /\bLAST\b/ }; - no strict 'refs'; - my %seen; - my @every = map { my $sub = "${_}::$wanted_method"; - !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub - } @forebears - unless $wanted_method eq 'AUTOLOAD'; - - my $want = wantarray; - if (@every) { - if ($want) { - return map {($_, [$self->$_(@_[1..$#_])])} @every; - } - elsif (defined $want) { - return { map {($_, scalar($self->$_(@_[1..$#_])))} - @every - }; - } - else { - $self->$_(@_[1..$#_]) for @every; - return; - } - } - - @every = map { my $sub = "${_}::AUTOLOAD"; - !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD" - } @forebears; - if ($want) { - return map { $$_ = ref($self)."::EVERY::".$wanted_method; - ($_, [$self->$_(@_[1..$#_])]); - } @every; - } - elsif (defined $want) { - return { map { $$_ = ref($self)."::EVERY::".$wanted_method; - ($_, scalar($self->$_(@_[1..$#_]))) - } @every - }; - } - else { - for (@every) { - $$_ = ref($self)."::EVERY::".$wanted_method; - $self->$_(@_[1..$#_]); - } - return; - } - }; -} - -package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD(); -package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD(); - -1; - -__END__ - -=head1 NAME - -NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch - - -=head1 SYNOPSIS - - use NEXT; - - package A; - sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() } - sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() } - - package B; - use base qw( A ); - sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } - sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() } - - package C; - sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() } - sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } - sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() } - - package D; - use base qw( B C ); - sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() } - sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() } - sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() } - - package main; - - my $obj = bless {}, "D"; - - $obj->method(); # Calls D::method, A::method, C::method - $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD - - # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY - - - -=head1 DESCRIPTION - -NEXT.pm adds a pseudoclass named C<NEXT> to any program -that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to -C<m> is redispatched as if the calling method had not originally been found. - -In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first, -left-to-right search of C<$self>'s class hierarchy that resulted in the -original call to C<m>. - -Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which -begins a new dispatch that is restricted to searching the ancestors -of the current class. C<$self-E<gt>NEXT::m()> can backtrack -past the current class -- to look for a suitable method in other -ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot. - -A typical use would be in the destructors of a class hierarchy, -as illustrated in the synopsis above. Each class in the hierarchy -has a DESTROY method that performs some class-specific action -and then redispatches the call up the hierarchy. As a result, -when an object of class D is destroyed, the destructors of I<all> -its parent classes are called (in depth-first, left-to-right order). - -Another typical use of redispatch would be in C<AUTOLOAD>'ed methods. -If such a method determined that it was not able to handle a -particular call, it might choose to redispatch that call, in the -hope that some other C<AUTOLOAD> (above it, or to its left) might -do better. - -By default, if a redispatch attempt fails to find another method -elsewhere in the objects class hierarchy, it quietly gives up and does -nothing (but see L<"Enforcing redispatch">). This gracious acquiescence -is also unlike the (generally annoying) behaviour of C<SUPER>, which -throws an exception if it cannot redispatch. - -Note that it is a fatal error for any method (including C<AUTOLOAD>) -to attempt to redispatch any method that does not have the -same name. For example: - - sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() } - - -=head2 Enforcing redispatch - -It is possible to make C<NEXT> redispatch more demandingly (i.e. like -C<SUPER> does), so that the redispatch throws an exception if it cannot -find a "next" method to call. - -To do this, simple invoke the redispatch as: - - $self->NEXT::ACTUAL::method(); - -rather than: - - $self->NEXT::method(); - -The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call, -or it should throw an exception. - -C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to -decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure -semantics: - - sub AUTOLOAD { - if ($AUTOLOAD =~ /foo|bar/) { - # handle here - } - else { # try elsewhere - shift()->NEXT::ACTUAL::AUTOLOAD(@_); - } - } - -By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the -method call, an exception will be thrown (as usually happens in the absence of -a suitable C<AUTOLOAD>). - - -=head2 Avoiding repetitions - -If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy: - - # A B - # / \ / - # C D - # \ / - # E - - use NEXT; - - package A; - sub foo { print "called A::foo\n"; shift->NEXT::foo() } - - package B; - sub foo { print "called B::foo\n"; shift->NEXT::foo() } - - package C; @ISA = qw( A ); - sub foo { print "called C::foo\n"; shift->NEXT::foo() } - - package D; @ISA = qw(A B); - sub foo { print "called D::foo\n"; shift->NEXT::foo() } - - package E; @ISA = qw(C D); - sub foo { print "called E::foo\n"; shift->NEXT::foo() } - - E->foo(); - -then derived classes may (re-)inherit base-class methods through two or -more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice -- -through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches -will invoke the multiply inherited method as many times as it is -inherited. For example, the above code prints: - - called E::foo - called C::foo - called A::foo - called D::foo - called A::foo - called B::foo - -(i.e. C<A::foo> is called twice). - -In some cases this I<may> be the desired effect within a diamond hierarchy, -but in others (e.g. for destructors) it may be more appropriate to -call each method only once during a sequence of redispatches. - -To cover such cases, you can redispatch methods via: - - $self->NEXT::DISTINCT::method(); - -rather than: - - $self->NEXT::method(); - -This causes the redispatcher to only visit each distinct C<method> method -once. That is, to skip any classes in the hierarchy that it has -already visited during redispatch. So, for example, if the -previous example were rewritten: - - package A; - sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() } - - package B; - sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() } - - package C; @ISA = qw( A ); - sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() } - - package D; @ISA = qw(A B); - sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() } - - package E; @ISA = qw(C D); - sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() } - - E->foo(); - -then it would print: - - called E::foo - called C::foo - called A::foo - called D::foo - called B::foo - -and omit the second call to C<A::foo> (since it would not be distinct -from the first call to C<A::foo>). - -Note that you can also use: - - $self->NEXT::DISTINCT::ACTUAL::method(); - -or: - - $self->NEXT::ACTUAL::DISTINCT::method(); - -to get both unique invocation I<and> exception-on-failure. - -Note that, for historical compatibility, you can also use -C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>. - - -=head2 Invoking all versions of a method with a single call - -Yet another pseudo-class that NEXT.pm provides is C<EVERY>. -Its behaviour is considerably simpler than that of the C<NEXT> family. -A call to: - - $obj->EVERY::foo(); - -calls I<every> method named C<foo> that the object in C<$obj> has inherited. -That is: - - use NEXT; - - package A; @ISA = qw(B D X); - sub foo { print "A::foo " } - - package B; @ISA = qw(D X); - sub foo { print "B::foo " } - - package X; @ISA = qw(D); - sub foo { print "X::foo " } - - package D; - sub foo { print "D::foo " } - - package main; - - my $obj = bless {}, 'A'; - $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo - -Prefixing a method call with C<EVERY::> causes every method in the -object's hierarchy with that name to be invoked. As the above example -illustrates, they are not called in Perl's usual "left-most-depth-first" -order. Instead, they are called "breadth-first-dependency-wise". - -That means that the inheritance tree of the object is traversed breadth-first -and the resulting order of classes is used as the sequence in which methods -are called. However, that sequence is modified by imposing a rule that the -appropriate method of a derived class must be called before the same method of -any ancestral class. That's why, in the above example, C<X::foo> is called -before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>. - -In general, there's no need to worry about the order of calls. They will be -left-to-right, breadth-first, most-derived-first. This works perfectly for -most inherited methods (including destructors), but is inappropriate for -some kinds of methods (such as constructors, cloners, debuggers, and -initializers) where it's more appropriate that the least-derived methods be -called first (as more-derived methods may rely on the behaviour of their -"ancestors"). In that case, instead of using the C<EVERY> pseudo-class: - - $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo - -you can use the C<EVERY::LAST> pseudo-class: - - $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo - -which reverses the order of method call. - -Whichever version is used, the actual methods are called in the same -context (list, scalar, or void) as the original call via C<EVERY>, and return: - -=over - -=item * - -A hash of array references in list context. Each entry of the hash has the -fully qualified method name as its key and a reference to an array containing -the method's list-context return values as its value. - -=item * - -A reference to a hash of scalar values in scalar context. Each entry of the hash has the -fully qualified method name as its key and the method's scalar-context return values as its value. - -=item * - -Nothing in void context (obviously). - -=back - -=head2 Using C<EVERY> methods - -The typical way to use an C<EVERY> call is to wrap it in another base -method, that all classes inherit. For example, to ensure that every -destructor an object inherits is actually called (as opposed to just the -left-most-depth-first-est one): - - package Base; - sub DESTROY { $_[0]->EVERY::Destroy } - - package Derived1; - use base 'Base'; - sub Destroy {...} - - package Derived2; - use base 'Base', 'Derived1'; - sub Destroy {...} - -et cetera. Every derived class than needs its own clean-up -behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method), -which the call to C<EVERY::LAST::Destroy> in the inherited destructor -then correctly picks up. - -Likewise, to create a class hierarchy in which every initializer inherited by -a new object is invoked: - - package Base; - sub new { - my ($class, %args) = @_; - my $obj = bless {}, $class; - $obj->EVERY::LAST::Init(\%args); - } - - package Derived1; - use base 'Base'; - sub Init { - my ($argsref) = @_; - ... - } - - package Derived2; - use base 'Base', 'Derived1'; - sub Init { - my ($argsref) = @_; - ... - } - -et cetera. Every derived class than needs some additional initialization -behaviour simply adds its own C<Init> method (I<not> a C<new> method), -which the call to C<EVERY::LAST::Init> in the inherited constructor -then correctly picks up. - - -=head1 AUTHOR - -Damian Conway (damian@conway.org) - -=head1 BUGS AND IRRITATIONS - -Because it's a module, not an integral part of the interpreter, NEXT.pm -has to guess where the surrounding call was found in the method -look-up sequence. In the presence of diamond inheritance patterns -it occasionally guesses wrong. - -It's also too slow (despite caching). - -Comment, suggestions, and patches welcome. - -=head1 COPYRIGHT - - Copyright (c) 2000-2001, Damian Conway. All Rights Reserved. - This module is free software. It may be used, redistributed - and/or modified under the same terms as Perl itself. diff --git a/lib/NEXT/Changes b/lib/NEXT/Changes deleted file mode 100644 index b691d25a28..0000000000 --- a/lib/NEXT/Changes +++ /dev/null @@ -1,60 +0,0 @@ -Revision history for Perl extension NEXT.pm. - -0.64 Mon Jun 8 14:36:00 2009 - - Fixed overwriting dynamically scoped regex vars (Norbert Buchmuller, - Closes RT#36956). - -0.63 Fri Apr 10 16:52:44 2009 - - Specify plans for all tests (Jarkko Hietaniemi). Merged from blead - perl (Florian Ragwitz). - - Default to installing to privlib instead of sitelib on perls where - NEXT is core (Jerry D. Hedden). - -0.62 Wed Apr 8 03:27:25 2009 - - Be less aggressive when looking at the symbol table to find - methods. This prevents "used only once" warnings on 5.10. - -0.61 Tue Mar 24 02:50:26 2009 - - Pod tweaks (Alan Ferrency). - - Fix a bug when using NEXT from within an eval block (Dave Rolsky). - - Fix some pod typos (Piotr Fusik). - - Fix a bug when using NEXT within overloaded stringification - (Marcel GrĂ¼nauer). - - Make NEXT work with AUTOLOAD (Damian Conway). - -0.60 Wed Aug 13 03:55:33 2003 - - Re-re-re-fixed NEXT::UNSEEN bug under diamond inheritance - (Note to self: don't code whilst on vacation!) - - Implemented and documented EVERY functionality - -0.53 Tue Aug 12 10:53:25 2003 - - Re-re-fixed NEXT::UNSEEN bug under diamond inheritance - -0.52 Wed Jul 30 21:06:59 2003 - - Refixed NEXT::UNSEEN bug under diamond inheritance - -0.51 Tue Jul 29 23:09:48 2003 - - Fixed NEXT::UNSEEN bug under diamond inheritance (thanks Dan - and Alan) - - Moved &ancestors out of NEXT class in case anyone ever - calls NEXT::ancestors - - Replaced UNSEEN with DISTINCT (but left UNSEEN operational - for backwards compatibility) - -0.50 Fri Nov 16 11:20:40 2001 - - Added a $VERSION (oops!) - - Fixed handling of diamond patterns (thanks Paul) - - Added NEXT::ACTUAL to require existence of next method (thanks Paul) - - Added NEXT::UNSEEN to avoid calling multiply inherited - methods twice (thanks Paul) - - Re-fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS to be - consistent with more useful SUPER:: behaviour - - Corified tests - -0.02 Mon Sep 3 07:52:27 2001 - - Fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS (thanks Leonid) - - Changed licence for inclusion in core distribution - - Documented the difference between NEXT and SUPER (thanks Ken) - -0.01 Tue Apr 10 18:27:00 EST 2001 - - original version diff --git a/lib/NEXT/README b/lib/NEXT/README deleted file mode 100644 index af8b5624ae..0000000000 --- a/lib/NEXT/README +++ /dev/null @@ -1,57 +0,0 @@ -============================================================================== - Release of version 0.60 of NEXT -============================================================================== - - -NAME - - NEXT - Pseudo class for method redispatch - - -DESCRIPTION - - NEXT.pm adds a pseudoclass named C<NEXT> to any program that - uses it. If a method C<m> calls C<$self->NEXT::m()>, the call to - C<m> is redispatched as if the calling method had not originally - been found. - - In other words, a call to C<$self->NEXT::m()> resumes the - depth-first, left-to-right search of parent classes that - resulted in the original call to C<m>. - - Note that this is not the same thing as C<$self->SUPER::m()>, which - begins a new dispatch that is restricted to searching the ancestors - of the current class. C<$self->NEXT::m()> can backtrack past - the current class -- to look for a suitable method in other - ancestors of C<$self> -- whereas C<$self->SUPER::m()> cannot. - - An particularly interesting use of redispatch is in - C<AUTOLOAD>'ed methods. If such a method determines that it is - not able to handle a particular call, it may choose to - redispatch that call, in the hope that some other C<AUTOLOAD> - (above it, or to its left) might do better. - - The module also allows you to specify that multiply inherited - methods should only be redispatched once, and what should - happen if no redispatch is possible. - - -AUTHOR - - Damian Conway (damian@conway.org) - - -COPYRIGHT - - Copyright (c) 2000-2001, Damian Conway. All Rights Reserved. - This module is free software. It may be used, redistributed - and/or modified under the same terms as Perl itself. - - -============================================================================== - -AVAILABILITY - -NEXT has been uploaded to the CPAN - -============================================================================== diff --git a/lib/NEXT/t/actual.t b/lib/NEXT/t/actual.t deleted file mode 100644 index a3a724ae4a..0000000000 --- a/lib/NEXT/t/actual.t +++ /dev/null @@ -1,44 +0,0 @@ -use Test::More tests => 10; - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir('t') if -d 't'; - @INC = qw(../lib); - } -} - -BEGIN { use_ok('NEXT') }; -my $order = 0; - -package A; -@ISA = qw/B C D/; - -sub test { ++$order; ::ok($order==1,"test A"); $_[0]->NEXT::ACTUAL::test;} - -package B; -@ISA = qw/D C/; -sub test { ++$order; ::ok($order==2,"test B"); $_[0]->NEXT::ACTUAL::test;} - -package C; -@ISA = qw/D/; -sub test { - ++$order; ::ok($order==4||$order==6,"test C"); - $_[0]->NEXT::ACTUAL::test; -} - -package D; - -sub test { - ++$order; ::ok($order==3||$order==5||$order==7||$order==8,"test D"); - $_[0]->NEXT::ACTUAL::test; -} - -package main; - -my $foo = {}; - -bless($foo,"A"); - -eval{ $foo->test } - ? fail("Didn't die on missing ancestor") - : pass("Correctly dies after full traversal"); diff --git a/lib/NEXT/t/actuns.t b/lib/NEXT/t/actuns.t deleted file mode 100644 index b3da0c69fd..0000000000 --- a/lib/NEXT/t/actuns.t +++ /dev/null @@ -1,38 +0,0 @@ -use Test::More tests => 6; - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir('t') if -d 't'; - @INC = qw(../lib); - } -} - -BEGIN { use_ok('NEXT') }; -my $order = 0; - -package A; -@ISA = qw/B C D/; - -sub test { ::ok(++$order==1,"test A"); $_[0]->NEXT::UNSEEN::ACTUAL::test;} - -package B; -@ISA = qw/D C/; -sub test { ::ok(++$order==2,"test B"); $_[0]->NEXT::ACTUAL::UNSEEN::test;} - -package C; -@ISA = qw/D/; -sub test { ::ok(++$order==4,"test C"); $_[0]->NEXT::UNSEEN::ACTUAL::test;} - -package D; - -sub test { ::ok(++$order==3,"test D"); $_[0]->NEXT::ACTUAL::UNSEEN::test;} - -package main; - -my $foo = {}; - -bless($foo,"A"); - -eval{ $foo->test } - ? fail("Didn't die on missing ancestor") - : pass("Correctly dies after C"); diff --git a/lib/NEXT/t/dynamically_scoped_regex_vars.t b/lib/NEXT/t/dynamically_scoped_regex_vars.t deleted file mode 100644 index 2d209e0e4c..0000000000 --- a/lib/NEXT/t/dynamically_scoped_regex_vars.t +++ /dev/null @@ -1,50 +0,0 @@ -use Test::More tests => 7; - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir('t') if -d 't'; - @INC = qw(../lib); - } -} - -BEGIN { use_ok('NEXT') }; - -package A; -use base qw(B); -use NEXT; -sub test_next { shift->NEXT::test_next(@_); } -sub test_next_distinct { shift->NEXT::DISTINCT::test_next_distinct(@_); } -sub test_next_actual { shift->NEXT::ACTUAL::test_next_actual(@_); } -sub test_next_actual_distinct { shift->NEXT::ACTUAL::DISTINCT::test_next_actual_distinct(@_); } -sub test_every { shift->EVERY::test_every(@_); } -sub test_every_last { shift->EVERY::LAST::test_every_last(@_); } - -package B; -sub test_next { $_[1]; } -sub test_next_distinct { $_[1]; } -sub test_next_actual { $_[1]; } -sub test_next_actual_distinct { $_[1]; } -sub test_every { $_[1]; } -sub test_every_last { $_[1]; } - -package main; - -my $foo = bless {}, 'A'; - -"42" =~ /(.*)/; -is($foo->test_next($&), $&, "The value of '\$&' was not overwritten in NEXT."); - -"42" =~ /(.*)/; -is($foo->test_next_distinct($&), $&, "The value of '\$&' was not overwritten in NEXT::DISTINCT."); - -"42" =~ /(.*)/; -is($foo->test_next_actual($&), $&, "The value of '\$&' was not overwritten in NEXT::ACTUAL."); - -"42" =~ /(.*)/; -is($foo->test_next_actual_distinct($&), $&, "The value of '\$&' was not overwritten in NEXT::ACTUAL::DISTINCT."); - -"42" =~ /(.*)/; -is($foo->test_every($&)->{'B::test_every'}, $&, "The value of '\$&' was not overwritten in EVERY."); - -"42" =~ /(.*)/; -is($foo->test_every_last($&)->{'B::test_every_last'}, $&, "The value of '\$&' was not overwritten in EVERY::LAST."); diff --git a/lib/NEXT/t/next.t b/lib/NEXT/t/next.t deleted file mode 100644 index 8b26f0e4aa..0000000000 --- a/lib/NEXT/t/next.t +++ /dev/null @@ -1,114 +0,0 @@ -BEGIN { - if ($ENV{PERL_CORE}) { - chdir('t') if -d 't'; - @INC = qw(../lib); - } -} - -BEGIN { print "1..26\n"; } - -use NEXT; - -print "ok 1\n"; - -package A; -sub A::method { return ( 3, $_[0]->NEXT::method() ) } -sub A::DESTROY { $_[0]->NEXT::DESTROY() } -sub A::evaled { eval { $_[0]->NEXT::evaled(); return 'evaled' } } - -package B; -use base qw( A ); -sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() ) - if $AUTOLOAD =~ /.*(missing_method|secondary)/ } -sub B::DESTROY { $_[0]->NEXT::DESTROY() } - -package C; -sub C::DESTROY { print "ok 24\n"; $_[0]->NEXT::DESTROY() } - -package D; -@D::ISA = qw( B C E ); -sub D::method { return ( 2, $_[0]->NEXT::method() ) } -sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) } -sub D::DESTROY { print "ok 23\n"; $_[0]->NEXT::DESTROY() } -sub D::oops { $_[0]->NEXT::method() } -sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) } - -package E; -@E::ISA = qw( F G ); -sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) } -sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() ) - if $AUTOLOAD =~ /.*(missing_method|secondary)/ } -sub E::DESTROY { print "ok 25\n"; $_[0]->NEXT::DESTROY() } - -package F; -sub F::method { return ( 5 ) } -sub F::AUTOLOAD { return ( 11 ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ } -sub F::DESTROY { print "ok 26\n" } - -package G; -sub G::method { return ( 6 ) } -sub G::AUTOLOAD { print "not "; return } -sub G::DESTROY { print "not ok 22"; return } - -package main; - -my $obj = bless {}, "D"; - -my @vals; - -# TEST NORMAL REDISPATCH (ok 2..6) -@vals = $obj->method(); -print map "ok $_\n", @vals; - -# RETEST NORMAL REDISPATCH SHOULD BE THE SAME (ok 7) -@vals = $obj->method(); -print "not " unless join("", @vals) == "23456"; -print "ok 7\n"; - -# TEST AUTOLOAD REDISPATCH (ok 8..11) -@vals = $obj->missing_method(); -print map "ok $_\n", @vals; - -# NAMED METHOD CAN'T REDISPATCH TO NAMED METHOD OF DIFFERENT NAME (ok 12) -eval { $obj->oops() } && print "not "; -print "ok 12\n"; - -# AUTOLOAD'ED METHOD CAN'T REDISPATCH TO NAMED METHOD (ok 13) - -eval { - local *C::AUTOLOAD = sub { $_[0]->NEXT::method() }; - *C::AUTOLOAD = *C::AUTOLOAD; - eval { $obj->missing_method(); } && print "not "; -}; -print "ok 13\n"; - -# NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14) -eval { - *C::method = sub{ $_[0]->NEXT::AUTOLOAD() }; - *C::method = *C::method; - eval { $obj->method(); } && print "not "; -}; -print "ok 14\n"; - -# BASE CLASS METHODS ONLY REDISPATCHED WITHIN HIERARCHY (ok 15..16) -my $ob2 = bless {}, "B"; -@val = $ob2->method(); -print "not " unless @val==1 && $val[0]==3; -print "ok 15\n"; - -@val = $ob2->missing_method(); -print "not " unless @val==1 && $val[0]==9; -print "ok 16\n"; - -# TEST SECONDARY AUTOLOAD REDISPATCH (ok 17..21) -@vals = $obj->secondary(); -print map "ok $_\n", @vals; - -# TEST HANDLING OF NEXT:: INSIDE EVAL (22) -eval { - $obj->evaled; - $@ && print "not "; -}; -print "ok 22\n"; - -# CAN REDISPATCH DESTRUCTORS (ok 23..26) diff --git a/lib/NEXT/t/stringify.t b/lib/NEXT/t/stringify.t deleted file mode 100644 index 8d06890ceb..0000000000 --- a/lib/NEXT/t/stringify.t +++ /dev/null @@ -1,35 +0,0 @@ -use warnings; -use strict; -use Test::More tests => 2; - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir('t') if -d 't'; - @INC = qw(../lib); - } -} - -BEGIN { use_ok('NEXT') }; - - -package Foo; - -use overload '""' => 'stringify'; - -use constant BAR => (1..5); - -sub new { bless {}, shift } - -sub stringify { - my $self = shift; - my %result = $self->EVERY::LAST::BAR; - join '-' => @{ $result{'Foo::BAR'} }; -} - - - -package main; - -my $foo = Foo->new; -is("$foo", '1-2-3-4-5', 'overloading stringification'); - diff --git a/lib/NEXT/t/unseen.t b/lib/NEXT/t/unseen.t deleted file mode 100644 index 5166816280..0000000000 --- a/lib/NEXT/t/unseen.t +++ /dev/null @@ -1,54 +0,0 @@ -use Test::More tests => 7; - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir('t') if -d 't'; - @INC = qw(../lib); - } -} - -BEGIN { use_ok('NEXT') }; -my $order = 0; - -package A; -@ISA = qw/B C D/; - -sub test { ::ok(++$order==1,"test A"); $_[0]->NEXT::UNSEEN::test; 1} - -package B; -@ISA = qw/D C/; -sub test { ::ok(++$order==2,"test B"); $_[0]->NEXT::UNSEEN::test; 1} - -package C; -@ISA = qw/D/; -sub test { ::ok(++$order==4,"test C"); $_[0]->NEXT::UNSEEN::test; 1} - -package D; - -sub test { ::ok(++$order==3,"test D"); $_[0]->NEXT::UNSEEN::test; 1} - -package main; - -my $foo = {}; - -bless($foo,"A"); - -eval{ $foo->test } - ? pass("Correctly survives after C") - : fail("Shouldn't die on missing ancestor"); - -package Diamond::Base; -my $seen; -sub test { - $seen++ ? ::fail("Can't visit inherited test twice") - : ::pass("First diamond is okay"); - shift->NEXT::UNSEEN::test; -} - -package Diamond::Left; @ISA = qw[Diamond::Base]; -package Diamond::Right; @ISA = qw[Diamond::Base]; -package Diamond::Top; @ISA = qw[Diamond::Left Diamond::Right]; - -package main; - -Diamond::Top->test; |