X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FNEXT.pm;h=51dec919640d9692d13de015990e19b7b8f1fa37;hb=06c0cc96ebd866767a6d107ed78967600f7e0395;hp=3d90696a1a61ac318354c4d481e67fb4c5883099;hpb=d36e5bffcaa31e87b66f7867bd33e8c225204efd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/NEXT.pm b/lib/NEXT.pm index 3d90696..51dec91 100644 --- a/lib/NEXT.pm +++ b/lib/NEXT.pm @@ -1,9 +1,9 @@ package NEXT; -$VERSION = '0.51'; +$VERSION = '0.60_01'; use Carp; use strict; -sub ancestors +sub NEXT::ELSEWHERE::ancestors { my @inlist = shift; my @outlist = (); @@ -15,10 +15,26 @@ sub 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) = @_; - my $caller = (caller(1))[3]; + my $depth = 1; + until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ } + my $caller = (caller($depth))[3]; my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD'; undef $NEXT::AUTOLOAD; my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g; @@ -32,7 +48,8 @@ sub AUTOLOAD unless ($NEXT::NEXT{$self,$wanted_method}) { my @forebears = - ancestors ref $self || $self, $wanted_class; + NEXT::ELSEWHERE::ancestors ref $self || $self, + $wanted_class; while (@forebears) { last if shift @forebears eq $caller_class } @@ -43,10 +60,11 @@ sub AUTOLOAD @{$NEXT::NEXT{$self,$wanted_method}} = map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears unless @{$NEXT::NEXT{$self,$wanted_method}||[]}; - $NEXT::SEEN->{$self,*{$caller}{CODE}}++; + $NEXT::SEEN->{$self,*{$caller}{CODE}}++; } my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}}; - while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && 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}}; } @@ -56,7 +74,7 @@ sub AUTOLOAD croak qq(Can't locate object method "$wanted_method" ), qq(via package "$caller_class"); }; - return shift()->$call_method(@_) if ref $call_method eq 'CODE'; + return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE'; no strict 'refs'; ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// if $wanted_method eq 'AUTOLOAD'; @@ -66,9 +84,79 @@ sub AUTOLOAD no strict 'vars'; package NEXT::UNSEEN; @ISA = 'NEXT'; +package NEXT::DISTINCT; @ISA = 'NEXT'; package NEXT::ACTUAL; @ISA = 'NEXT'; 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 $depth = 1; + until ((caller($depth))[3] !~ /^\(eval\)$/) { $depth++ } + my $caller = (caller($depth))[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; @@ -76,7 +164,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 @@ -113,21 +201,22 @@ 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 -that uses it. If a method C calls C<$self->NEXT::m()>, the call to +that uses it. If a method C calls C<$self-ENEXT::m()>, the call to C 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, +In other words, a call to C<$self-ENEXT::m()> resumes the depth-first, left-to-right search of C<$self>'s class hierarchy that resulted in the original call to C. -Note that this is not the same thing as C<$self->SUPER::m()>, which +Note that this is not the same thing as C<$self-ESUPER::m()>, which begins a new dispatch that is restricted to searching the ancestors -of the current class. C<$self->NEXT::m()> can backtrack +of the current class. C<$self-ENEXT::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. +ancestors of C<$self> -- whereas C<$self-ESUPER::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 @@ -144,7 +233,7 @@ 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 +nothing (but see L<"Enforcing redispatch">). This gracious acquiescence is also unlike the (generally annoying) behaviour of C, which throws an exception if it cannot redispatch. @@ -240,30 +329,31 @@ call each method only once during a sequence of redispatches. To cover such cases, you can redispatch methods via: - $self->NEXT::UNSEEN::method(); + $self->NEXT::DISTINCT::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 +This causes the redispatcher to only visit each distinct C 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::UNSEEN::foo() } + sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() } package B; - sub foo { print "called B::foo\n"; shift->NEXT::UNSEEN::foo() } + 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::UNSEEN::foo() } + 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::UNSEEN::foo() } + 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::UNSEEN::foo() } + sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() } E->foo(); @@ -275,18 +365,155 @@ then it would print: called D::foo called B::foo -and omit the second call to C. +and omit the second call to C (since it would not be distinct +from the first call to C). Note that you can also use: - $self->NEXT::UNSEEN::ACTUAL::method(); + $self->NEXT::DISTINCT::ACTUAL::method(); or: - $self->NEXT::ACTUAL::UNSEEN::method(); + $self->NEXT::ACTUAL::DISTINCT::method(); 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 +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 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