From: Jarkko Hietaniemi Date: Thu, 14 Aug 2003 18:29:19 +0000 (+0000) Subject: Upgrade to NEXT 0.60. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bf5734d48cfc03fbca4e85c5e0afdb1758ace04f;p=p5sagit%2Fp5-mst-13.2.git Upgrade to NEXT 0.60. p4raw-id: //depot/perl@20712 --- diff --git a/lib/NEXT.pm b/lib/NEXT.pm index 04dd8de..5738f5c 100644 --- a/lib/NEXT.pm +++ b/lib/NEXT.pm @@ -1,5 +1,5 @@ package NEXT; -$VERSION = '0.52'; +$VERSION = '0.60'; use Carp; use strict; @@ -15,6 +15,20 @@ sub NEXT::ELSEWHERE::ancestors 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 AUTOLOAD { my ($self) = @_; @@ -47,7 +61,8 @@ sub AUTOLOAD $NEXT::SEEN->{$self,*{$caller}{CODE}}++; } my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; - while ($wanted_class =~ /^NEXT:.*:(UNSEEN|DISTINCT):/ && defined $call_method + while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ + && defined $call_method && $NEXT::SEEN->{$self,$call_method}++) { $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; } @@ -73,7 +88,71 @@ package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; + +package EVERY::LAST; @ISA = 'EVERY'; package EVERY; @ISA = 'NEXT'; +sub AUTOLOAD +{ + my ($self) = @_; + my $caller = (caller(1))[3]; + my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD'; + undef $EVERY::AUTOLOAD; + my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g; + + local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} = + $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}; + + return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++; + + my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self, + $wanted_class; + @forebears = reverse @forebears if $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; + } +} + 1; @@ -81,7 +160,7 @@ __END__ =head1 NAME -NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch +NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch =head1 SYNOPSIS @@ -118,6 +197,7 @@ NEXT.pm - Provide a pseudo-class NEXT that allows method redispatch # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY + =head1 DESCRIPTION NEXT.pm adds a pseudoclass named C to any program @@ -297,6 +377,140 @@ to get both unique invocation I exception-on-failure. Note that, for historical compatibility, you can also use C instead of C. + +=head2 Invoking all versions of a method with a single call + +Yet another pseudo-class that NEXT.pm provides is C. +Its behaviour is considerably simpler than that of the C family. +A call to: + + $obj->EVERY::foo(); + +calls I method named C 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 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 +appropritae method of a derived class must be called before the same method of +any ancestral class. That's why, in the above example, C is called +before C, even though C comes before C 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 pseudo-class: + + $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo + +you can use the C 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, 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 methods + +The typical way to use an C 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 method (I a C method), +which the call to C 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 method (I a C method), +which the call to C in the inherited constructor +then correctly picks up. + + =head1 AUTHOR Damian Conway (damian@conway.org) diff --git a/lib/NEXT/Changes b/lib/NEXT/Changes index 9bd1ebf..fc34098 100644 --- a/lib/NEXT/Changes +++ b/lib/NEXT/Changes @@ -53,3 +53,17 @@ Revision history for Perl extension NEXT.pm. 0.52 Wed Jul 30 21:06:59 2003 + - Refixed NEXT::UNSEEN bug under diamond inheritance + + +0.53 Tue Aug 12 10:53:25 2003 + + - Re-re-fixed NEXT::UNSEEN bug under diamond inheritance + + +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 diff --git a/lib/NEXT/README b/lib/NEXT/README index 42fe91d..a60aae0 100644 --- a/lib/NEXT/README +++ b/lib/NEXT/README @@ -1,5 +1,5 @@ ============================================================================== - Release of version 0.52 of NEXT + Release of version 0.60 of NEXT ============================================================================== @@ -50,9 +50,13 @@ COPYRIGHT ============================================================================== -CHANGES IN VERSION 0.52 +CHANGES IN VERSION 0.60 + - Re-re-re-fixed NEXT::UNSEEN bug under diamond inheritance + (Note to self: don't code whilst on vacation!) + + - Implemented and documented EVERY functionality ============================================================================== diff --git a/lib/NEXT/t/actual.t b/lib/NEXT/t/actual.t index e451840..dbd040d 100644 --- a/lib/NEXT/t/actual.t +++ b/lib/NEXT/t/actual.t @@ -1,3 +1,5 @@ +use Test::More 'no_plan'; + BEGIN { if ($ENV{PERL_CORE}) { chdir('t') if -d 't'; @@ -5,27 +7,31 @@ BEGIN { } } -BEGIN { print "1..9\n"; } -use NEXT; - -my $count=1; +BEGIN { use_ok('NEXT') }; +my $order = 0; package A; @ISA = qw/B C D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;} +sub test { ++$order; ::ok($order==1,"test A"); $_[0]->NEXT::ACTUAL::test;} package B; -@ISA = qw/C D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;} +@ISA = qw/D C/; +sub test { ++$order; ::ok($order==2,"test B"); $_[0]->NEXT::ACTUAL::test;} package C; @ISA = qw/D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;} +sub test { + ++$order; ::ok($order==4||$order==6,"test C"); + $_[0]->NEXT::ACTUAL::test; +} package D; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::test;} +sub test { + ++$order; ::ok($order==3||$order==5||$order==7||$order==8,"test D"); + $_[0]->NEXT::ACTUAL::test; +} package main; @@ -33,5 +39,6 @@ my $foo = {}; bless($foo,"A"); -eval { $foo->test } and print "not "; -print "ok 9\n"; +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 index aca30c7..a99fbe5 100644 --- a/lib/NEXT/t/actuns.t +++ b/lib/NEXT/t/actuns.t @@ -1,3 +1,5 @@ +use Test::More 'no_plan'; + BEGIN { if ($ENV{PERL_CORE}) { chdir('t') if -d 't'; @@ -5,27 +7,25 @@ BEGIN { } } -BEGIN { print "1..6\n"; } -use NEXT; - -my $count=1; +BEGIN { use_ok('NEXT') }; +my $order = 0; package A; @ISA = qw/B C D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;} +sub test { ::ok(++$order==1,"test A"); $_[0]->NEXT::UNSEEN::ACTUAL::test;} package B; -@ISA = qw/C D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;} +@ISA = qw/D C/; +sub test { ::ok(++$order==2,"test B"); $_[0]->NEXT::ACTUAL::UNSEEN::test;} package C; @ISA = qw/D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::ACTUAL::test;} +sub test { ::ok(++$order==4,"test C"); $_[0]->NEXT::UNSEEN::ACTUAL::test;} package D; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::ACTUAL::UNSEEN::test;} +sub test { ::ok(++$order==3,"test D"); $_[0]->NEXT::ACTUAL::UNSEEN::test;} package main; @@ -33,4 +33,6 @@ my $foo = {}; bless($foo,"A"); -eval { $foo->test } and print "not "; +eval{ $foo->test } + ? fail("Didn't die on missing ancestor") + : pass("Correctly dies after C"); diff --git a/lib/NEXT/t/unseen.t b/lib/NEXT/t/unseen.t index ddaab18..1304ad6 100644 --- a/lib/NEXT/t/unseen.t +++ b/lib/NEXT/t/unseen.t @@ -1,3 +1,5 @@ +use Test::More 'no_plan'; + BEGIN { if ($ENV{PERL_CORE}) { chdir('t') if -d 't'; @@ -5,27 +7,25 @@ BEGIN { } } -BEGIN { print "1..10\n"; } -use NEXT; - -my $count=1; +BEGIN { use_ok('NEXT') }; +my $order = 0; package A; @ISA = qw/B C D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;} +sub test { ::ok(++$order==1,"test A"); $_[0]->NEXT::UNSEEN::test; 1} package B; -@ISA = qw/C D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;} +@ISA = qw/D C/; +sub test { ::ok(++$order==2,"test B"); $_[0]->NEXT::UNSEEN::test; 1} package C; @ISA = qw/D/; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;} +sub test { ::ok(++$order==4,"test C"); $_[0]->NEXT::UNSEEN::test; 1} package D; -sub test { print "ok ", $count++, "\n"; $_[0]->NEXT::UNSEEN::test;} +sub test { ::ok(++$order==3,"test D"); $_[0]->NEXT::UNSEEN::test; 1} package main; @@ -33,10 +33,17 @@ my $foo = {}; bless($foo,"A"); -$foo->test; +eval{ $foo->test } + ? pass("Correctly survives after C") + : fail("Shouldn't die on missing ancestor"); package Diamond::Base; -sub test { print "ok ", $count++, "\n"; shift->NEXT::UNSEEN::test; } +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];