Change 13117 by jhi@alpha on 2001/11/20 02:53:32
Upgrade to NEXT 0.50.
Affected files ...
.... //depot/perl/MANIFEST#626 edit
.... //depot/perl/lib/NEXT.pm#3 edit
.... //depot/perl/lib/NEXT/Changes#2 edit
.... //depot/perl/lib/NEXT/README#3 edit
.... //depot/perl/lib/NEXT/t/actual.t#1 add
.... //depot/perl/lib/NEXT/t/actuns.t#1 add
.... //depot/perl/lib/NEXT/t/next.t#1 add
.... //depot/perl/lib/NEXT/t/unseen.t#1 add
.... //depot/perl/lib/NEXT/test.pl#3 delete
Differences ...
==== //depot/perl/MANIFEST#626 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Mon Nov 19 20:00:05 2001
+++ perl/MANIFEST Mon Nov 19 20:00:05 2001
@@ -1128,7 +1128,10 @@
lib/NEXT.pm Pseudo-class NEXT for method redispatch
lib/NEXT/Changes NEXT
lib/NEXT/README NEXT
-lib/NEXT/test.pl See if NEXT works
+lib/NEXT/t/actual.t NEXT
+lib/NEXT/t/actuns.t NEXT
+lib/NEXT/t/next.t NEXT
+lib/NEXT/t/unseen.t NEXT
lib/open.pm Pragma to specify default I/O disciplines
lib/open.t See if the open pragma works
lib/open2.pl Open a two-ended pipe (uses IPC::Open2)
==== //depot/perl/lib/NEXT.pm#3 (text) ====
Index: perl/lib/NEXT.pm
--- perl/lib/NEXT.pm.~1~ Mon Nov 19 20:00:05 2001
+++ perl/lib/NEXT.pm Mon Nov 19 20:00:05 2001
@@ -1,13 +1,14 @@
package NEXT;
+$VERSION = '0.50';
use Carp;
use strict;
sub ancestors
{
- my @inlist = @_;
+ my @inlist = shift;
my @outlist = ();
- while (@inlist) {
- push @outlist, shift @inlist;
+ while (my $next = shift @inlist) {
+ push @outlist, $next;
no strict 'refs';
unshift @inlist, @{"$outlist[-1]::ISA"};
}
@@ -25,11 +26,13 @@
croak "Can't call $wanted from $caller"
unless $caller_method eq $wanted_method;
- local $NEXT::NEXT{$self,$wanted_method} =
- $NEXT::NEXT{$self,$wanted_method};
+ local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
+ ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
+
- unless (@{$NEXT::NEXT{$self,$wanted_method}||[]}) {
- my @forebears = ancestors ref $self;
+ unless ($NEXT::NEXT{$self,$wanted_method}) {
+ my @forebears =
+ ancestors ref $self || $self, $wanted_class;
while (@forebears) {
last if shift @forebears eq $caller_class
}
@@ -38,22 +41,34 @@
map { *{"${_}::$caller_method"}{CODE}||() } @forebears
unless $wanted_method eq 'AUTOLOAD';
@{$NEXT::NEXT{$self,$wanted_method}} =
- map { (*{"${_}::AUTOLOAD"}{CODE}) ?
- "${_}::AUTOLOAD" : () } @forebears
+ map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()}
+@forebears
unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
}
my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
- return unless defined $call_method;
- if (ref $call_method eq 'CODE') {
- return shift()->$call_method(@_)
+ while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
+ && $NEXT::SEEN->{$self,$call_method}++) {
+ $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
}
- else { # AN AUTOLOAD
- no strict 'refs';
- ${$call_method} = $caller_method eq 'AUTOLOAD' &&
${"${caller_class}::AUTOLOAD"} || $wanted;
- return $call_method->(@_);
- }
+ unless (defined $call_method) {
+ return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
+ (local $Carp::CarpLevel)++;
+ croak qq(Can't locate object method "$wanted_method" ),
+ qq(via package "$caller_class");
+ };
+ return shift()->$call_method(@_) if ref $call_method eq 'CODE';
+ no strict 'refs';
+ ($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::UNSEEN; @ISA = 'NEXT';
+package NEXT::ACTUAL; @ISA = 'NEXT';
+package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
+package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
+
1;
__END__
@@ -65,36 +80,36 @@
=head1 SYNOPSIS
- use NEXT;
+ 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 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 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 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 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;
+ package main;
- my $obj = bless {}, "D";
+ my $obj = bless {}, "D";
- $obj->method(); # Calls D::method, A::method, C::method
- $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
+ $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
+ # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
=head1 DESCRIPTION
@@ -126,10 +141,150 @@
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 acquiesence
+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 except itself. For example:
+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::UNSEEN::method();
+
+rather than:
+
+ $self->NEXT::method();
+
+This causes the redispatcher to skip any classes in the hierarchy that it has
+already visited in an earlier redispatch. So, for example, if the
+previous example were rewritten:
+
+ package A;
+ sub foo { print "called A::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package B;
+ sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package C; @ISA = qw( A );
+ sub foo { print "called C::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package D; @ISA = qw(A B);
+ sub foo { print "called D::foo\n"; shift->NEXT::UNSEEN::foo() }
+
+ package E; @ISA = qw(C D);
+ sub foo { print "called E::foo\n"; shift->NEXT::UNSEEN::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>.
+
+Note that you can also use:
+
+ $self->NEXT::UNSEEN::ACTUAL::method();
+
+or:
+
+ $self->NEXT::ACTUAL::UNSEEN::method();
- sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+to get both unique invocation I<and> exception-on-failure.
=head1 AUTHOR
==== //depot/perl/lib/NEXT/Changes#2 (text) ====
Index: perl/lib/NEXT/Changes
--- perl/lib/NEXT/Changes.~1~ Mon Nov 19 20:00:05 2001
+++ perl/lib/NEXT/Changes Mon Nov 19 20:00:05 2001
@@ -20,3 +20,20 @@
- Fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS (thanks Leonid)
- Changed licence for inclusion in core distribution
+
+
+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
==== //depot/perl/lib/NEXT/README#3 (text) ====
Index: perl/lib/NEXT/README
--- perl/lib/NEXT/README.~1~ Mon Nov 19 20:00:05 2001
+++ perl/lib/NEXT/README Mon Nov 19 20:00:05 2001
@@ -1,5 +1,5 @@
==============================================================================
- Release of version 0.02 of NEXT
+ Release of version 0.50 of NEXT
==============================================================================
@@ -31,11 +31,10 @@
redispatch that call, in the hope that some other C<AUTOLOAD>
(above it, or to its left) might do better.
- Note that it is a fatal error for any method (including C<AUTOLOAD>)
- to attempt to redispatch any method except itself. For example:
+ 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.
- sub D::oops { $_[0]->NEXT::other_method() } # BANG!
-
AUTHOR
@@ -51,12 +50,22 @@
==============================================================================
-CHANGES IN VERSION 0.02
+CHANGES IN VERSION 0.50
+
+
+ - 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)
- - Fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS (thanks Leonid)
+ - Re-fixed setting of $AUTOLOAD in NEXT'd AUTOLOADS to be
+ consistent with more useful SUPER:: behaviour
- - Changed licence for inclusion in core distribution
+ - Corified tests
==============================================================================
==== //depot/perl/lib/NEXT/t/actual.t#1 (text) ====
Index: perl/lib/NEXT/t/actual.t
--- perl/lib/NEXT/t/actual.t.~1~ Mon Nov 19 20:00:05 2001
+++ perl/lib/NEXT/t/actual.t Mon Nov 19 20:00:05 2001
@@ -0,0 +1,37 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..9\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+eval { $foo->test } and print "not ";
+print "ok 9\n";
==== //depot/perl/lib/NEXT/t/actuns.t#1 (text) ====
Index: perl/lib/NEXT/t/actuns.t
--- perl/lib/NEXT/t/actuns.t.~1~ Mon Nov 19 20:00:05 2001
+++ perl/lib/NEXT/t/actuns.t Mon Nov 19 20:00:05 2001
@@ -0,0 +1,37 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..5\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+eval { $foo->test } and print "not ";
+print "ok 5\n";
==== //depot/perl/lib/NEXT/t/next.t#1 (text) ====
Index: perl/lib/NEXT/t/next.t
--- perl/lib/NEXT/t/next.t.~1~ Mon Nov 19 20:00:05 2001
+++ perl/lib/NEXT/t/next.t Mon Nov 19 20:00:05 2001
@@ -0,0 +1,106 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..25\n"; }
+
+use NEXT;
+
+print "ok 1\n";
+
+package A;
+sub A::method { return ( 3, $_[0]->NEXT::method() ) }
+sub A::DESTROY { $_[0]->NEXT::DESTROY() }
+
+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 23\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 22\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 24\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 25\n" }
+
+package G;
+sub G::method { return ( 6 ) }
+sub G::AUTOLOAD { print "not "; return }
+sub G::DESTROY { print "not ok 21"; 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;
+
+# CAN REDISPATCH DESTRUCTORS (ok 22..25)
==== //depot/perl/lib/NEXT/t/unseen.t#1 (text) ====
Index: perl/lib/NEXT/t/unseen.t
--- perl/lib/NEXT/t/unseen.t.~1~ Mon Nov 19 20:00:05 2001
+++ perl/lib/NEXT/t/unseen.t Mon Nov 19 20:00:05 2001
@@ -0,0 +1,36 @@
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { print "1..4\n"; }
+use NEXT;
+
+my $count=1;
+
+package A;
+@ISA = qw/B C D/;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package B;
+@ISA = qw/C D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package C;
+@ISA = qw/D/;
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package D;
+
+sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;}
+
+package main;
+
+my $foo = {};
+
+bless($foo,"A");
+
+$foo->test;
End of Patch.
