From 13021a801cfcd7c449594b5981d5c50bebea8e98 Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Tue, 20 Nov 2001 02:53:32 +0000 Subject: [PATCH] Upgrade to NEXT 0.50. p4raw-id: //depot/perl@13117 --- MANIFEST | 5 +- lib/NEXT.pm | 237 ++++++++++++++++++++++++++++++++++------- lib/NEXT/Changes | 17 +++ lib/NEXT/README | 25 +++-- lib/NEXT/t/actual.t | 37 +++++++ lib/NEXT/t/actuns.t | 37 +++++++ lib/NEXT/{test.pl => t/next.t} | 7 +- lib/NEXT/t/unseen.t | 36 +++++++ 8 files changed, 350 insertions(+), 51 deletions(-) create mode 100644 lib/NEXT/t/actual.t create mode 100644 lib/NEXT/t/actuns.t rename lib/NEXT/{test.pl => t/next.t} (96%) create mode 100644 lib/NEXT/t/unseen.t diff --git a/MANIFEST b/MANIFEST index cfc6bbd..42e4ab2 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1128,7 +1128,10 @@ lib/newgetopt.pl A perl library supporting long option parsing 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) diff --git a/lib/NEXT.pm b/lib/NEXT.pm index e41065c..68b3df2 100644 --- a/lib/NEXT.pm +++ b/lib/NEXT.pm @@ -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 @@ sub AUTOLOAD 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 @@ sub AUTOLOAD 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(@_) - } - else { # AN AUTOLOAD - no strict 'refs'; - ${$call_method} = $caller_method eq 'AUTOLOAD' && ${"${caller_class}::AUTOLOAD"} || $wanted; - return $call_method->(@_); + while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method + && $NEXT::SEEN->{$self,$call_method}++) { + $call_method = shift @{$NEXT::NEXT{$self,$wanted_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 @@ NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch =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 @@ particular call, it might choose to redispatch that call, in the hope that some other C (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, which +throws an exception if it cannot redispatch. + Note that it is a fatal error for any method (including C) -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 redispatch more demandingly (i.e. like +C 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 tells C that there must actually be a next method to call, +or it should throw an exception. + +C is most commonly used in C methods, as a means to +decline an C 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, if there is no other C to handle the +method call, an exception will be thrown (as usually happens in the absence of +a suitable C). + + +=head2 Avoiding repetitions + +If C 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 inherits C twice -- +through C and C). In such cases, a sequence of C 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 is called twice). + +In some cases this I 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. + +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 exception-on-failure. =head1 AUTHOR diff --git a/lib/NEXT/Changes b/lib/NEXT/Changes index bb5e27a..f6f7bff 100644 --- a/lib/NEXT/Changes +++ b/lib/NEXT/Changes @@ -20,3 +20,20 @@ Revision history for Perl extension NEXT.pm. - 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 diff --git a/lib/NEXT/README b/lib/NEXT/README index 7202d00..ad750bc 100644 --- a/lib/NEXT/README +++ b/lib/NEXT/README @@ -1,5 +1,5 @@ ============================================================================== - Release of version 0.02 of NEXT + Release of version 0.50 of NEXT ============================================================================== @@ -31,10 +31,9 @@ DESCRIPTION redispatch that call, in the hope that some other C (above it, or to its left) might do better. - Note that it is a fatal error for any method (including C) - to attempt to redispatch any method except itself. For example: - - sub D::oops { $_[0]->NEXT::other_method() } # BANG! + 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 @@ -51,12 +50,22 @@ COPYRIGHT ============================================================================== -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 ============================================================================== diff --git a/lib/NEXT/t/actual.t b/lib/NEXT/t/actual.t new file mode 100644 index 0000000..e451840 --- /dev/null +++ b/lib/NEXT/t/actual.t @@ -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"; diff --git a/lib/NEXT/t/actuns.t b/lib/NEXT/t/actuns.t new file mode 100644 index 0000000..3795681 --- /dev/null +++ b/lib/NEXT/t/actuns.t @@ -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"; diff --git a/lib/NEXT/test.pl b/lib/NEXT/t/next.t similarity index 96% rename from lib/NEXT/test.pl rename to lib/NEXT/t/next.t index 0ba0b66..8cc493f 100644 --- a/lib/NEXT/test.pl +++ b/lib/NEXT/t/next.t @@ -1,4 +1,9 @@ -#! /usr/local/bin/perl -w +BEGIN { + if ($ENV{PERL_CORE}) { + chdir('t') if -d 't'; + @INC = qw(../lib); + } +} BEGIN { print "1..25\n"; } diff --git a/lib/NEXT/t/unseen.t b/lib/NEXT/t/unseen.t new file mode 100644 index 0000000..af8d1f7 --- /dev/null +++ b/lib/NEXT/t/unseen.t @@ -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; -- 2.7.4