overload (2 bugs): fallback/nomethod failures with heterogeneous operands #10020
Comments
From perl@mbreen.comblead 5.11.2 / all versions These two bugs are distinct but related: the second one was exposed by some of the test code added for the first. Note: The documentation for overload is ambiguous on the correct mechanics and precedence of fallback and nomethod where there are two overloaded operands. Bug 1If two operands are overloaded and the first has fallback>0 then the second operand's nomethod is never called - even if it is the only implementation. package NuMB; package NuMBnomethod; package NuMBfall1; package main; # BUG 1 # BUG 2 Bug 2With two overloaded operands of different types, neither of which defines a 'nomethod' method, the decision on whether to fall back to the default implemention of the operator is determined solely by the second operand. While this is even more obviously wrong than the first bug, the correct behaviour may be less clear: Flags: This is perl 5, version 11, subversion 2 (v5.11.2-157-g0f907b9*) built for i686-linux |
From perl@mbreen.comJust to be clear about the sample code, for Bug 1 the correct output |
From perl@mbreen.com71286-overload-2-bugs-fallback-nomethod.patchFrom 3d5f8a7648213e35f3a3074f22a25441518bb19e Mon Sep 17 00:00:00 2001
From: Michael Breen <perl@mbreen.com>
Date: Tue, 15 Dec 2009 08:24:54 +0000
Subject: [PATCH] [perl #71286] overload (2 bugs): fallback/nomethod failures with heterogeneous operands
---
gv.c | 25 +++++++--
lib/overload.t | 146 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 164 insertions(+), 7 deletions(-)
diff --git a/gv.c b/gv.c
index 9743354..c6ceddd 100644
--- a/gv.c
+++ b/gv.c
@@ -1825,6 +1825,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
int postpr = 0, force_cpy = 0;
int assign = AMGf_assign & flags;
const int assignshift = assign ? 1 : 0;
+ int use_default_op = 0;
#ifdef DEBUGGING
int fl=0;
#endif
@@ -1989,9 +1990,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
- } else if (((ocvp && oamtp->fallback > AMGfallNEVER
- && (cvp=ocvp) && (lr = -1))
- || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
+ } else if (((cvp && amtp->fallback > AMGfallNEVER)
+ || (ocvp && oamtp->fallback > AMGfallNEVER))
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
@@ -2019,7 +2019,17 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
off = scmp_amg;
break;
}
- if ((off != -1) && (cv = cvp[off]))
+ if (off != -1) {
+ if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
+ cv = ocvp[off];
+ lr = -1;
+ }
+ if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
+ cv = cvp[off];
+ lr = 1;
+ }
+ }
+ if (cv)
postpr = 1;
else
goto not_found;
@@ -2039,7 +2049,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
notfound = 1; lr = -1;
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
- } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
+ } else if ((use_default_op =
+ (!ocvp || oamtp->fallback >= AMGfallYES)
+ && (!cvp || amtp->fallback >= AMGfallYES))
+ && !DEBUG_o_TEST) {
/* Skip generating the "no method found" message. */
return NULL;
} else {
@@ -2063,7 +2076,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
SvAMAGIC(right)?
HvNAME_get(SvSTASH(SvRV(right))):
""));
- if (amtp && amtp->fallback >= AMGfallYES) {
+ if (use_default_op) {
DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
} else {
Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
diff --git a/lib/overload.t b/lib/overload.t
index 39333cf..5eee6b1 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -47,7 +47,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
package main;
$| = 1;
-use Test::More tests => 607;
+use Test::More tests => 661;
$a = new Oscalar "087";
@@ -1590,4 +1590,148 @@ foreach my $op (qw(<=> == != < <= > >=)) {
is($y, $o, "copy constructor falls back to assignment (preinc)");
}
+{
+ # fallback to 'cmp' and '<=>' with heterogeneous operands
+ # [perl #71286]
+ my $not_found = 'no method found';
+ my $used = 0;
+ package CmpBase;
+ sub new {
+ my $n = $_[1] || 0;
+ bless \$n, ref $_[0] || $_[0];
+ }
+ sub cmp {
+ $used = \$_[0];
+ (${$_[0]} <=> ${$_[1]}) * ($_[2] ? -1 : 1);
+ }
+
+ package NCmp;
+ use base 'CmpBase';
+ use overload '<=>' => 'cmp';
+
+ package SCmp;
+ use base 'CmpBase';
+ use overload 'cmp' => 'cmp';
+
+ package main;
+ my $n = NCmp->new(5);
+ my $s = SCmp->new(3);
+ my $res;
+
+ eval { $res = $n > $s; };
+ $res = $not_found if $@ =~ /$not_found/;
+ is($res, 1, 'A>B using A<=> when B overloaded, no B<=>');
+
+ eval { $res = $s < $n; };
+ $res = $not_found if $@ =~ /$not_found/;
+ is($res, 1, 'A<B using B<=> when A overloaded, no A<=>');
+
+ eval { $res = $s lt $n; };
+ $res = $not_found if $@ =~ /$not_found/;
+ is($res, 1, 'A lt B using A:cmp when B overloaded, no B:cmp');
+
+ eval { $res = $n gt $s; };
+ $res = $not_found if $@ =~ /$not_found/;
+ is($res, 1, 'A gt B using B:cmp when A overloaded, no A:cmp');
+
+ my $o = NCmp->new(9);
+ $res = $n < $o;
+ is($used, \$n, 'A < B uses <=> from A in preference to B');
+
+ my $t = SCmp->new(7);
+ $res = $s lt $t;
+ is($used, \$s, 'A lt B uses cmp from A in preference to B');
+}
+
+{
+ # Combinatorial testing of 'fallback' and 'nomethod'
+ # [perl #71286]
+ package NuMB;
+ use overload '0+' => sub { ${$_[0]}; },
+ '""' => 'str';
+ sub new {
+ my $self = shift;
+ my $n = @_ ? shift : 0;
+ bless my $obj = \$n, ref $self || $self;
+ }
+ sub str {
+ no strict qw/refs/;
+ my $s = "(${$_[0]} ";
+ $s .= "nomethod, " if defined ${ref($_[0]).'::(nomethod'};
+ my $fb = ${ref($_[0]).'::()'};
+ $s .= "fb=" . (defined $fb ? 0 + $fb : 'undef') . ")";
+ }
+ sub nomethod { "${$_[0]}.nomethod"; }
+
+ # create classes for tests
+ package main;
+ my @falls = (0, 'undef', 1);
+ my @nomethods = ('', 'nomethod');
+ my $not_found = 'no method found';
+ for my $fall (@falls) {
+ for my $nomethod (@nomethods) {
+ my $nomethod_decl = $nomethod
+ ? $nomethod . "=>'nomethod'," : '';
+ eval qq{
+ package NuMB$fall$nomethod;
+ use base qw/NuMB/;
+ use overload $nomethod_decl
+ fallback => $fall;
+ };
+ }
+ }
+
+ # operation and precedence of 'fallback' and 'nomethod'
+ # for all combinations with 2 overloaded operands
+ for my $nomethod2 (@nomethods) {
+ for my $nomethod1 (@nomethods) {
+ for my $fall2 (@falls) {
+ my $pack2 = "NuMB$fall2$nomethod2";
+ for my $fall1 (@falls) {
+ my $pack1 = "NuMB$fall1$nomethod1";
+ my ($test, $out, $exp);
+ eval qq{
+ my \$x = $pack1->new(2);
+ my \$y = $pack2->new(3);
+ \$test = "\$x" . ' * ' . "\$y";
+ \$out = \$x * \$y;
+ };
+ $out = $not_found if $@ =~ /$not_found/;
+ $exp = $nomethod1 ? '2.nomethod' :
+ $nomethod2 ? '3.nomethod' :
+ $fall1 eq '1' && $fall2 eq '1' ? 6
+ : $not_found;
+ is($out, $exp, "$test --> $exp");
+ }
+ }
+ }
+ }
+
+ # operation of 'fallback' and 'nomethod'
+ # where the other operand is not overloaded
+ for my $nomethod (@nomethods) {
+ for my $fall (@falls) {
+ my ($test, $out, $exp);
+ eval qq{
+ my \$x = NuMB$fall$nomethod->new(2);
+ \$test = "\$x" . ' * 3';
+ \$out = \$x * 3;
+ };
+ $out = $not_found if $@ =~ /$not_found/;
+ $exp = $nomethod ? '2.nomethod' :
+ $fall eq '1' ? 6
+ : $not_found;
+ is($out, $exp, "$test --> $exp");
+
+ eval qq{
+ my \$x = NuMB$fall$nomethod->new(2);
+ \$test = '3 * ' . "\$x";
+ \$out = 3 * \$x;
+ };
+ $out = $not_found if $@ =~ /$not_found/;
+ is($out, $exp, "$test --> $exp");
+ }
+ }
+}
+
# EOF
--
1.5.6.5
|
From [Unknown Contact. See original ticket]Just to be clear about the sample code, for Bug 1 the correct output |
|
perl@mbreen.com - Status changed from 'new' to 'open' |
From @obraOn Tue Dec 15 00:37:59 2009, breen wrote:
This doesn't appear to be a regression (tested against 5.10 and 5.8.). As Thanks for the patch, |
From perl@mbreen.com
You're correct: it's not a regression. And I can understand |
From perl@mbreen.comThis ticket does not appear to have progressed since last year. And it's I'm not even using Perl at the moment so I'm almost past caring. Still, |
From [Unknown Contact. See original ticket]This ticket does not appear to have progressed since last year. And it's I'm not even using Perl at the moment so I'm almost past caring. Still, |
From @cpansproutOn Tue Oct 19 22:30:04 2010, breen wrote:
I understand how you feel. It was the same way with my patches. (But I I have your patch on my list. I have not got to it yet, for three |
From perl@mbreen.comFCVR>time (1500 open bugs). That's a sobering number. Thank you for your reply, FC. |
From @iabynOn Mon, Dec 14, 2009 at 10:54:25PM -0800, Michael Breen wrote:
Sorry that we've collectively failed to do anything with your patch for
Have we put you off completely, or are you still willing to do this?
I had to think for a while to decide whether this should fallback with Here's the commit message - let me know if its not an accurate summary of commit bf5522a [perl #71286] fallback/nomethod failures M gv.c -- |
From perl@mbreen.comOn Fri Dec 03 04:42:52 2010, davem wrote:
Thank you, Dave. Your commit message looks fine to me.
I had ideas and had planned a full rewrite to fix this and other Thanks again. |
From perl@mbreen.com
Copy / paste error. Should be: here in #71286 |
From perl@mbreen.com[perl #82278] raised for the related shortcomings in the documentation |
|
@iabyn - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#71286 (status was 'resolved')
Searchable as RT71286$
The text was updated successfully, but these errors were encountered: