[perl #109542] Make num ops treat $1 as "$1"

Numeric ops were not taking magical variables into account.  So $1 (a
magical variable) would be treated differently from "$1" (a non-magi-
cal variable0.

In determining whether to use an integer operation, they would call
SvIV_please_nomg, and then check whether the sv was SvIOK as a result.

SvIV_please_nomg would call SvIV_nomg if the sv were SvPOK or SvNOK.

The problem here is that gmagical variables are never SvIOK, but
only SvIOKp.

In fact, the private flags are used differently for gmagical and non-
magical variables.  For non-gmagical variables, the private flag indi-
cates that there is a cached value.  If the public flag is not set,
then the cached value is imprecise.  For gmagical variables, imprecise
values are never cached; only the private flags are used, and they are
equivalent to the public flags on non-gmagical variables.

This commit changes SvIV_please_nomg to take gmagical variables
into account, using the newly-added sv_gmagical_2iv_please (see the
docs for it in the diff).  SvIV_please_nomg now returns true or
false, not void, since a subsequent SvIOK is not reliable.  So
‘SvIV_please_nomg(sv); if(SvIOK)’ becomes ‘if(SvIV_please_nomg(sv))’.

8 files changed, 101 insertions, 40 deletions

diff --git a/embed.fnc b/embed.fnc
index 1f5047c16c..5bfa543dce 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1311,6 +1311,7 @@ Apd	|STRLEN	|sv_len		|NULLOK SV *const sv
 Apd	|STRLEN	|sv_len_utf8	|NULLOK SV *const sv
 Apd	|void	|sv_magic	|NN SV *const sv|NULLOK SV *const obj|const int how \
 				|NULLOK const char *const name|const I32 namlen
+pd	|bool	|sv_gmagical_2iv_please|NN SV *sv
 Apd	|MAGIC *|sv_magicext	|NN SV *const sv|NULLOK SV *const obj|const int how \
 				|NULLOK const MGVTBL *const vtbl|NULLOK const char *const name \
 				|const I32 namlen
diff --git a/embed.h b/embed.h
index 1815481d2f..781366bd17 100644
--- a/embed.h
+++ b/embed.h
@@ -1197,6 +1197,7 @@
 #define sv_clean_objs()		Perl_sv_clean_objs(aTHX)
 #define sv_del_backref(a,b)	Perl_sv_del_backref(aTHX_ a,b)
 #define sv_free_arenas()	Perl_sv_free_arenas(aTHX)
+#define sv_gmagical_2iv_please(a)	Perl_sv_gmagical_2iv_please(aTHX_ a)
 #define sv_ref(a,b,c)		Perl_sv_ref(aTHX_ a,b,c)
 #define sv_sethek(a,b)		Perl_sv_sethek(aTHX_ a,b)
 #ifndef PERL_IMPLICIT_CONTEXT
diff --git a/pp.c b/pp.c
index 0370caa27b..fbeb3ae29a 100644
--- a/pp.c
+++ b/pp.c
@@ -1024,11 +1024,7 @@ PP(pp_pow)
     /* For integer to integer power, we do the calculation by hand wherever
        we're sure it is safe; otherwise we call pow() and try to convert to
        integer afterwards. */
-    {
-	SvIV_please_nomg(svr);
-	if (SvIOK(svr)) {
-	    SvIV_please_nomg(svl);
-	    if (SvIOK(svl)) {
+    if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
 		UV power;
 		bool baseuok;
 		UV baseuv;
@@ -1126,8 +1122,6 @@ PP(pp_pow)
 			RETURN;
 		    } 
 		}
-	    }
-	}
     }
   float_it:
 #endif    
@@ -1191,14 +1185,12 @@ PP(pp_multiply)
     svr = TOPs;
     svl = TOPm1s;
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please_nomg(svr);
-    if (SvIOK(svr)) {
+    if (SvIV_please_nomg(svr)) {
 	/* Unless the left argument is integer in range we are going to have to
 	   use NV maths. Hence only attempt to coerce the right argument if
 	   we know the left is integer.  */
 	/* Left operand is defined, so is it IV? */
-	SvIV_please_nomg(svl);
-	if (SvIOK(svl)) {
+	if (SvIV_please_nomg(svl)) {
 	    bool auvok = SvUOK(svl);
 	    bool buvok = SvUOK(svr);
 	    const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
@@ -1336,10 +1328,7 @@ PP(pp_divide)
 #endif
 
 #ifdef PERL_TRY_UV_DIVIDE
-    SvIV_please_nomg(svr);
-    if (SvIOK(svr)) {
-        SvIV_please_nomg(svl);
-        if (SvIOK(svl)) {
+    if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
             bool left_non_neg = SvUOK(svl);
             bool right_non_neg = SvUOK(svr);
             UV left;
@@ -1414,8 +1403,7 @@ PP(pp_divide)
                     RETURN;
                 } /* tried integer divide but it was not an integer result */
             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
-        } /* left wasn't SvIOK */
-    } /* right wasn't SvIOK */
+    } /* one operand wasn't SvIOK */
 #endif /* PERL_TRY_UV_DIVIDE */
     {
 	NV right = SvNV_nomg(svr);
@@ -1447,8 +1435,7 @@ PP(pp_modulo)
 	NV dleft  = 0.0;
 	SV * const svr = TOPs;
 	SV * const svl = TOPm1s;
-	SvIV_please_nomg(svr);
-        if (SvIOK(svr)) {
+        if (SvIV_please_nomg(svr)) {
             right_neg = !SvUOK(svr);
             if (!right_neg) {
                 right = SvUVX(svr);
@@ -1478,9 +1465,7 @@ PP(pp_modulo)
         /* At this point use_double is only true if right is out of range for
            a UV.  In range NV has been rounded down to nearest UV and
            use_double false.  */
-        SvIV_please_nomg(svl);
-	if (!use_double && SvIOK(svl)) {
-            if (SvIOK(svl)) {
+	if (!use_double && SvIV_please_nomg(svl)) {
                 left_neg = !SvUOK(svl);
                 if (!left_neg) {
                     left = SvUVX(svl);
@@ -1493,7 +1478,6 @@ PP(pp_modulo)
                         left = -aiv;
                     }
                 }
-            }
         }
 	else {
 	    dleft = SvNV_nomg(svl);
@@ -1708,8 +1692,7 @@ PP(pp_subtract)
 #ifdef PERL_PRESERVE_IVUV
     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
        "bad things" happen if you rely on signed integers wrapping.  */
-    SvIV_please_nomg(svr);
-    if (SvIOK(svr)) {
+    if (SvIV_please_nomg(svr)) {
 	/* Unless the left argument is integer in range we are going to have to
 	   use NV maths. Hence only attempt to coerce the right argument if
 	   we know the left is integer.  */
@@ -1723,8 +1706,7 @@ PP(pp_subtract)
 	    /* left operand is undef, treat as zero.  */
 	} else {
 	    /* Left operand is defined, so is it IV? */
-	    SvIV_please_nomg(svl);
-	    if (SvIOK(svl)) {
+	    if (SvIV_please_nomg(svl)) {
 		if ((auvok = SvUOK(svl)))
 		    auv = SvUVX(svl);
 		else {
@@ -1952,11 +1934,8 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
 
     PERL_ARGS_ASSERT_DO_NCMP;
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please_nomg(right);
     /* Fortunately it seems NaN isn't IOK */
-    if (SvIOK(right)) {
-	SvIV_please_nomg(left);
-	if (SvIOK(left)) {
+    if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
 	    if (!SvUOK(left)) {
 		const IV leftiv = SvIVX(left);
 		if (!SvUOK(right)) {
@@ -1992,7 +1971,6 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
 		}
 	    }
 	    /* NOTREACHED */
-	}
     }
 #endif
     {
diff --git a/pp_hot.c b/pp_hot.c
index 59ff881a93..5338fd7407 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -505,9 +505,7 @@ PP(pp_add)
        unsigned code below is actually shorter than the old code. :-)
     */
 
-    SvIV_please_nomg(svr);
-
-    if (SvIOK(svr)) {
+    if (SvIV_please_nomg(svr)) {
 	/* Unless the left argument is integer in range we are going to have to
 	   use NV maths. Hence only attempt to coerce the right argument if
 	   we know the left is integer.  */
@@ -523,8 +521,7 @@ PP(pp_add)
 	       lots of code to speed up what is probably a rarish case.  */
 	} else {
 	    /* Left operand is defined, so is it IV? */
-	    SvIV_please_nomg(svl);
-	    if (SvIOK(svl)) {
+	    if (SvIV_please_nomg(svl)) {
 		if ((auvok = SvUOK(svl)))
 		    auv = SvUVX(svl);
 		else {
diff --git a/proto.h b/proto.h
index b6dbd5c3b6..02bc3ccbc7 100644
--- a/proto.h
+++ b/proto.h
@@ -3959,6 +3959,11 @@ PERL_CALLCONV char*	Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 appen
 #define PERL_ARGS_ASSERT_SV_GETS	\
 	assert(sv); assert(fp)
 
+PERL_CALLCONV bool	Perl_sv_gmagical_2iv_please(pTHX_ SV *sv)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_GMAGICAL_2IV_PLEASE	\
+	assert(sv)
+
 PERL_CALLCONV char*	Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_GROW	\
diff --git a/sv.c b/sv.c
index b4716dbf25..2034c002b0 100644
--- a/sv.c
+++ b/sv.c
@@ -2332,6 +2332,28 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
 }
 
 /*
+=for apidoc sv_gmagical_2iv_please
+
+Used internally by C<SvIV_please_nomg>, this function sets the C<SvIVX>
+slot if C<sv_2iv> would have made the scalar C<SvIOK> had it not been
+magical.  In that case it returns true.
+
+=cut
+*/
+
+bool
+Perl_sv_gmagical_2iv_please(pTHX_ register SV *sv)
+{
+    bool has_int;
+    PERL_ARGS_ASSERT_SV_GMAGICAL_2IV_PLEASE;
+    assert(SvGMAGICAL(sv) && !SvIOKp(sv) && (SvNOKp(sv) || SvPOKp(sv)));
+    if (S_sv_2iuv_common(aTHX_ sv)) { SvNIOK_off(sv); return 0; }
+    has_int = !!SvIOK(sv);
+    SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+    return has_int;
+}
+
+/*
 =for apidoc sv_2uv_flags
 
 Return the unsigned integer value of an SV, doing any necessary string
diff --git a/sv.h b/sv.h
index 90785177a6..6d26f85a7e 100644
--- a/sv.h
+++ b/sv.h
@@ -1208,8 +1208,14 @@ the scalar's value cannot change unless written to.
 	STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
 		(void) SvIV(sv); } STMT_END
 #define SvIV_please_nomg(sv) \
-	STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
-		(void) SvIV_nomg(sv); } STMT_END
+	(!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv)) \
+	    ? (SvIV_nomg(sv), SvIOK(sv))	  \
+	    : SvGMAGICAL(sv)			   \
+		? SvIOKp(sv) || (		    \
+		       (SvNOKp(sv) || SvPOKp(sv))    \
+		    && sv_gmagical_2iv_please(sv)     \
+		  )				       \
+		: SvIOK(sv))
 #define SvIV_set(sv, val) \
 	STMT_START { \
 		assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]);	\
diff --git a/t/op/arith.t b/t/op/arith.t
index 58c1f75dec..290640244a 100644
--- a/t/op/arith.t
+++ b/t/op/arith.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..145\n";
+print "1..159\n";
 
 sub try ($$) {
    print +($_[1] ? "ok" : "not ok"), " $_[0]\n";
@@ -324,3 +324,54 @@ else {
   }
   print "ok ", $T++, "\n";
 }
+
+# [perl #109542] $1 and "$1" should be treated the same way
+"976562500000000" =~ /(\d+)/;
+$a = ($1 * 1024);
+$b = ("$1" * 1024);
+print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" * something\n';
+$a = (1024 * $1);
+$b = (1024 * "$1");
+print "not "x($a ne $b), "ok ", $T++, qq ' - something * \$1 vs "\$1"\n';
+$a = ($1 + 102400000000000);
+$b = ("$1" + 102400000000000);
+print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" + something\n';
+$a = (102400000000000 + $1);
+$b = (102400000000000 + "$1");
+print "not "x($a ne $b), "ok ", $T++, qq ' - something + \$1 vs "\$1"\n';
+$a = ($1 - 10240000000000000);
+$b = ("$1" - 10240000000000000);
+print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" - something\n';
+$a = (10240000000000000 - $1);
+$b = (10240000000000000 - "$1");
+print "not "x($a ne $b), "ok ", $T++, qq ' - something - \$1 vs "\$1"\n';
+"976562500" =~ /(\d+)/;
+$a = ($1 ** 2);
+$b = ("$1" ** 2);
+print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" ** something\n';
+"32" =~ /(\d+)/;
+$a = (3 ** $1);
+$b = (3 ** "$1");
+print "not "x($a ne $b), "ok ", $T++, qq ' - something ** \$1 vs "\$1"\n';
+"97656250000000000" =~ /(\d+)/;
+$a = ($1 / 10);
+$b = ("$1" / 10);
+print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" / something\n';
+"10" =~ /(\d+)/;
+$a = (97656250000000000 / $1);
+$b = (97656250000000000 / "$1");
+print "not "x($a ne $b), "ok ", $T++, qq ' - something / \$1 vs "\$1"\n';
+"97656250000000000" =~ /(\d+)/;
+$a = ($1 <=> 97656250000000001);
+$b = ("$1" <=> 97656250000000001);
+print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" <=> something\n';
+$a = (97656250000000001 <=> $1);
+$b = (97656250000000001 <=> "$1");
+print "not "x($a ne $b), "ok ", $T++, qq ' - something <=> \$1 vs "\$1"\n';
+"97656250000000001" =~ /(\d+)/;
+$a = ($1 % 97656250000000002);
+$b = ("$1" % 97656250000000002);
+print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" % something\n';
+$a = (97656250000000000 % $1);
+$b = (97656250000000000 % "$1");
+print "not "x($a ne $b), "ok ", $T++, qq ' - something % \$1 vs "\$1"\n';