[perl #87708] Fix ‘$tied binop $tied’

The short story: In 5.13.1 or .2 these ops started calling get-magic
just once if the same gmagical scalar was used for both operands. Then
the same value would be used on both sides. In 5.12 FETCH would be
called twice with both return values used, but they would be swapped
in most cases (so $t/$t would return 1.5 if $t returned 2 and then
3). Now FETCH is called twice and the two operands are used in the
right order.

Up till now there have been patches to fix specific ops, but I real-
ised that the same ten or so lines of code would have to be added to
the rest of the 20+ pp_ functions, all of which use tryAMAGICbin_MG
(which calls Perl_try_amagic_bin in gv.c), so it made sense to add the
code to Perl_try_amagic_bin instead. This fixes all the ops in one
fell swoop.

The code in question checks whether the left and right operands are
the same gmagical scalar. If so, it copies the scalar into a new mor-
tal one, and then calls get-magic on the original operand to get its
new value (for the rhs). The new scalar is placed just below the top
of the stack, so it becomes the left operand.

This does slow down the bitwise integer ops slightly, but only in this
rare edge case. And the simplification of the code seems worth it.

Forthcoming are commits that revert some of the changes already made,
as this commit renders them unnecessary.

diff --git a/gv.c b/gv.c
index b1bc60f..2abe418 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2077,9 +2077,21 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) {
            return TRUE;
        }
     }
+    if(left==right && SvGMAGICAL(left)) {
+       SV * const left = sv_newmortal();
+       *(sp-1) = left;
+       /* Print the uninitialized warning now, so it includes the vari-
+          able name. */
+       if (!SvOK(right)) {
+           if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
+           sv_setsv_flags(left, &PL_sv_no, 0);
+       }
+       else sv_setsv_flags(left, right, 0);
+       SvGETMAGIC(right);
+    }
     if (flags & AMGf_numeric) {
-       if (SvROK(left))
-           *(sp-1) = sv_2num(left);
+       if (SvROK(TOPm1s))
+           *(sp-1) = sv_2num(TOPm1s);
        if (SvROK(right))
            *sp     = sv_2num(right);
     }

diff --git a/pp.h b/pp.h
index 7ae6afa..ca45f61 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -358,7 +358,7 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
     SV *rightsv = POPs;                                        \
     SV *leftsv = CAT2(X,s);                            \
     IV left = USE_LEFT(leftsv) ? SvIV_nomg(leftsv) : 0;        \
-    IV right = SvIV(rightsv)
+    IV right = SvIV_nomg(rightsv)
 
 #define dPOPPOPssrl    dPOPXssrl(POP)
 #define dPOPPOPnnrl    dPOPXnnrl(POP)

diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index df1c0fe..e90f2e6 100644 (file)
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -196,34 +196,29 @@ sub bin_int_test {
     check_count "$op under use integer", 2;
 }
 
-our $TODO;
-my  $todo = 'bug #87708';
-{
-    local $TODO = $todo;
-    bin_test '**',  2, 3, 8;
-    bin_test '*' ,  2, 3, 6;
-    bin_test '/' , 10, 2, 5;
-    bin_test '%' , 11, 2, 1;
-    bin_test 'x' , 11, 2, 1111;
-    bin_test '-' , 11, 2, 9;
-    bin_test '<<', 11, 2, 44;
-    bin_test '>>', 44, 2, 11;
-    bin_test '<' ,  1, 2, 1;
-    bin_test '>' , 44, 2, 1;
-    bin_test '<=', 44, 2, "";
-    bin_test '>=',  1, 2, "";
-    bin_test '!=',  1, 2, 1;
-    bin_test '<=>', 1, 2, -1;
-    bin_test 'le',  4, 2, "";
-    bin_test 'lt',  1, 2, 1;
-    bin_test 'gt',  4, 2, 1;
-    bin_test 'ge',  1, 2, "";
-    bin_test 'eq',  1, 2, "";
-    bin_test 'ne',  1, 2, 1;
-    bin_test 'cmp', 1, 2, -1;
-    bin_test '&' ,  1, 2, 0;
-    bin_test '|' ,  1, 2, 3;
-}
+bin_test '**',  2, 3, 8;
+bin_test '*' ,  2, 3, 6;
+bin_test '/' , 10, 2, 5;
+bin_test '%' , 11, 2, 1;
+bin_test 'x' , 11, 2, 1111;
+bin_test '-' , 11, 2, 9;
+bin_test '<<', 11, 2, 44;
+bin_test '>>', 44, 2, 11;
+bin_test '<' ,  1, 2, 1;
+bin_test '>' , 44, 2, 1;
+bin_test '<=', 44, 2, "";
+bin_test '>=',  1, 2, "";
+bin_test '!=',  1, 2, 1;
+bin_test '<=>', 1, 2, -1;
+bin_test 'le',  4, 2, "";
+bin_test 'lt',  1, 2, 1;
+bin_test 'gt',  4, 2, 1;
+bin_test 'ge',  1, 2, "";
+bin_test 'eq',  1, 2, "";
+bin_test 'ne',  1, 2, 1;
+bin_test 'cmp', 1, 2, -1;
+bin_test '&' ,  1, 2, 0;
+bin_test '|' ,  1, 2, 3;
 bin_test '.' ,  1, 2, 12;
 bin_test '==',  1, 2, "";
 bin_test '+' ,  1, 2, 3;