package NEXT;
-$VERSION = '0.50';
+$VERSION = '0.60_03';
use Carp;
use strict;
+use overload ();
-sub ancestors
+sub NEXT::ELSEWHERE::ancestors
{
my @inlist = shift;
my @outlist = ();
return @outlist;
}
-sub AUTOLOAD
+sub NEXT::ELSEWHERE::ordered_ancestors
{
- my ($self) = @_;
- my $caller = (caller(1))[3];
- my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
- undef $NEXT::AUTOLOAD;
- my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
- my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
- croak "Can't call $wanted from $caller"
- unless $caller_method eq $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 || $self, $wanted_class;
- while (@forebears) {
- last if shift @forebears eq $caller_class
- }
+ my @inlist = shift;
+ my @outlist = ();
+ while (my $next = shift @inlist) {
+ push @outlist, $next;
no strict 'refs';
- @{$NEXT::NEXT{$self,$wanted_method}} =
- map { *{"${_}::$caller_method"}{CODE}||() } @forebears
- unless $wanted_method eq 'AUTOLOAD';
- @{$NEXT::NEXT{$self,$wanted_method}} =
- map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
- unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
- }
- my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
- while ($wanted_class =~ /^NEXT:.*:UNSEEN/ && defined $call_method
- && $NEXT::SEEN->{$self,$call_method}++) {
- $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
+ push @inlist, @{"$outlist[-1]::ISA"};
}
- 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->(@_);
+ 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) = $caller =~ m{(.*)::(.*)}g;
+ my ($wanted_class, $wanted_method) = $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 { *{"${_}::$caller_method"}{CODE}||() } @forebears
+ unless $wanted_method eq 'AUTOLOAD';
+ @{$NEXT::NEXT{$key,$wanted_method}} =
+ map { (*{"${_}::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 ($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 $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';
+ ($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';
+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) = $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 $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;
=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
# 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->NEXT::m()>, the call to
+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->NEXT::m()> resumes the depth-first,
+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->SUPER::m()>, which
+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->NEXT::m()> can backtrack
+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->SUPER::m()> cannot.
+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
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<SUPER>, which
throws an exception if it cannot redispatch.
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> 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();
called D::foo
called B::foo
-and omit the second call to C<A::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::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<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
https://perl5.git.perl.org / perl5.git / blobdiff