Change 34007 by [EMAIL PROTECTED] on 2008/06/07 12:11:34
Integrate:
[ 23075]
Subject: Bug with NEXT when called from an eval block
From: Dave Rolsky <[EMAIL PROTECTED]>
Date: Fri, 9 Jul 2004 17:06:07 -0500 (CDT)
Message-ID: <[EMAIL PROTECTED]>
[ 25261]
Subject: [PATCH] Typos in *.p[lm]
From: "Piotr Fusik" <[EMAIL PROTECTED]>
Date: Sun, 31 Jul 2005 12:50:04 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 33943]
Integrate:
...
[ 33416]
Subject: Re: [PATCH] NEXT.pm bug within overloaded stringification
From: Marcel Grünauer <[EMAIL PROTECTED]>
Message-Id: <[EMAIL PROTECTED]>
Date: Mon, 3 Mar 2008 16:08:48 +0100
(a resend of <[EMAIL PROTECTED]>)
...
[ 33439]
Bump VERSION after change #33416
(so we don't end up with different code but same version in
5.10.0 and, say, 5.10.1)
...
[ 34006]
Integrate:
[ 33991]
Update to NEXT by Damian.
This fixes the working of NEXT with AUTOLOAD.
[ 33995]
Bump NEXT version to 0.61 for CPAN release
Affected files ...
... //depot/maint-5.8/perl/lib/NEXT.pm#6 integrate
... //depot/maint-5.8/perl/lib/NEXT/t/next.t#2 integrate
... //depot/maint-5.8/perl/lib/NEXT/t/stringify.t#1 branch
Differences ...
==== //depot/maint-5.8/perl/lib/NEXT.pm#6 (text) ====
Index: perl/lib/NEXT.pm
--- perl/lib/NEXT.pm#5~20782~ 2003-08-19 10:24:25.000000000 -0700
+++ perl/lib/NEXT.pm 2008-06-07 05:11:34.000000000 -0700
@@ -1,7 +1,8 @@
package NEXT;
-$VERSION = '0.60';
+$VERSION = '0.61';
use Carp;
use strict;
+use overload ();
sub NEXT::ELSEWHERE::ancestors
{
@@ -29,130 +30,151 @@
: 0 } @outlist;
}
-sub AUTOLOAD
+sub NEXT::ELSEWHERE::buildAUTOLOAD
{
- 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 =
- NEXT::ELSEWHERE::ancestors ref $self || $self,
- $wanted_class;
- while (@forebears) {
- last if shift @forebears eq $caller_class
- }
- 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}||[]};
- $NEXT::SEEN->{$self,*{$caller}{CODE}}++;
- }
- my $call_method = shift @{$NEXT::NEXT{$self,$wanted_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}};
- }
- 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->(@_);
+ 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::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 $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;
- }
+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;
@@ -229,7 +251,7 @@
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.
@@ -416,7 +438,7 @@
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
+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>.
==== //depot/maint-5.8/perl/lib/NEXT/t/next.t#2 (text) ====
Index: perl/lib/NEXT/t/next.t
--- perl/lib/NEXT/t/next.t#1~17645~ 2002-07-19 12:29:57.000000000 -0700
+++ perl/lib/NEXT/t/next.t 2008-06-07 05:11:34.000000000 -0700
@@ -5,7 +5,7 @@
}
}
-BEGIN { print "1..25\n"; }
+BEGIN { print "1..26\n"; }
use NEXT;
@@ -14,6 +14,7 @@
package A;
sub A::method { return ( 3, $_[0]->NEXT::method() ) }
sub A::DESTROY { $_[0]->NEXT::DESTROY() }
+sub A::evaled { eval { $_[0]->NEXT::evaled(); return 'evaled' } }
package B;
use base qw( A );
@@ -22,13 +23,13 @@
sub B::DESTROY { $_[0]->NEXT::DESTROY() }
package C;
-sub C::DESTROY { print "ok 23\n"; $_[0]->NEXT::DESTROY() }
+sub C::DESTROY { print "ok 24\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::DESTROY { print "ok 23\n"; $_[0]->NEXT::DESTROY() }
sub D::oops { $_[0]->NEXT::method() }
sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) }
@@ -37,17 +38,17 @@
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() }
+sub E::DESTROY { print "ok 25\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" }
+sub F::DESTROY { print "ok 26\n" }
package G;
sub G::method { return ( 6 ) }
sub G::AUTOLOAD { print "not "; return }
-sub G::DESTROY { print "not ok 21"; return }
+sub G::DESTROY { print "not ok 22"; return }
package main;
@@ -103,4 +104,11 @@
@vals = $obj->secondary();
print map "ok $_\n", @vals;
-# CAN REDISPATCH DESTRUCTORS (ok 22..25)
+# TEST HANDLING OF NEXT:: INSIDE EVAL (22)
+eval {
+ $obj->evaled;
+ $@ && print "not ";
+};
+print "ok 22\n";
+
+# CAN REDISPATCH DESTRUCTORS (ok 23..26)
==== //depot/maint-5.8/perl/lib/NEXT/t/stringify.t#1 (text) ====
Index: perl/lib/NEXT/t/stringify.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/NEXT/t/stringify.t 2008-06-07 05:11:34.000000000 -0700
@@ -0,0 +1,35 @@
+use warnings;
+use strict;
+use Test::More tests => 2;
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+BEGIN { use_ok('NEXT') };
+
+
+package Foo;
+
+use overload '""' => 'stringify';
+
+use constant BAR => (1..5);
+
+sub new { bless {}, shift }
+
+sub stringify {
+ my $self = shift;
+ my %result = $self->EVERY::LAST::BAR;
+ join '-' => @{ $result{'Foo::BAR'} };
+}
+
+
+
+package main;
+
+my $foo = Foo->new;
+is("$foo", '1-2-3-4-5', 'overloading stringification');
+
End of Patch.
