infnan: numify warning testing.

diff --git a/sv.c b/sv.c
index 1e85a72..1024c54 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2249,7 +2249,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv)
            sv_upgrade(sv, SVt_PVNV);
 
         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
-            if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_NAN)))
+            if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
                not_a_number(sv);
             S_sv_setnv(aTHX_ sv, numtype);
             return FALSE;

diff --git a/t/op/infnan.t b/t/op/infnan.t
index 6e59121..ae84111 100644 (file)
--- a/t/op/infnan.t
+++ b/t/op/infnan.t
@@ -404,22 +404,6 @@ SKIP: {
     is("a" x $NaN, "", "x NaN");
 }
 
-{
-    my $w;
-    local $SIG{__WARN__} = sub { $w = shift };
-    local $^W = 1;
-    my $a;
-    eval '$a = "nancy" + 1';
-    is($a, "$NaN", "nancy plus one is $NaN");
-    like($w, qr/^Argument "nancy" isn't numeric/, "nancy numify (compile time)");
-
-    my $n = "nanana";
-    my $b;
-    eval '$b = $n + 1';
-    is($b, "$NaN", "$n plus one is $NaN");
-    like($w, qr/^Argument "$n" isn't numeric/, "$n numify (runtime)");
-}
-
 # === Tests combining Inf and NaN ===
 
 # is() okay with $NaN because it uses eq.
@@ -462,4 +446,70 @@ cmp_ok('1e-9999',  '==', 0,     "underflow to 0 (runtime) from pos");
 cmp_ok(-1e-9999,   '==', 0,     "underflow to 0 (compile time) from neg");
 cmp_ok('-1e-9999', '==', 0,     "underflow to 0 (runtime) from neg");
 
+# === Warnings triggered when and only when appropriate ===
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w = shift };
+    local $^W = 1;
+
+    my $T =
+        [
+         [ "inf",          0, $PInf ],
+         [ "infxy",        1, $PInf ],
+         [ "inf34",        1, $PInf ],
+         [ "1.#INF",       0, $PInf ],
+         [ "1.#INFx",      1, $PInf ],
+         [ "1.#INF00",     0, $PInf ],
+         [ "1.#INFxy",     1, $PInf ],
+
+         [ "nan",          0, $NaN ],
+         [ "nanxy",        1, $NaN ],
+         [ "nan34",        1, $NaN ],
+         [ "nanq",         0, $NaN ],
+         [ "nans",         0, $NaN ],
+         [ "nanx",         1, $NaN ],
+         [ "nanqy",        1, $NaN ],
+         [ "nan(123)",     0, $NaN ],
+         [ "nan(0x123)",   0, $NaN ],
+         [ "nan(123xy)",   1, $NaN ],
+         [ "nan(0x123xy)", 1, $NaN ],
+         [ "nanq(123)",    0, $NaN ],
+         [ "nan(123",      1, $NaN ],
+         [ "nan(",         1, $NaN ],
+         [ "1.#NANQ",      0, $NaN ],
+         [ "1.#QNAN",      0, $NaN ],
+         [ "1.#NANQx",     1, $NaN ],
+         [ "1.#QNANx",     1, $NaN ],
+         [ "1.#IND",       0, $NaN ],
+         [ "1.#IND00",     0, $NaN ],
+         [ "1.#INDxy",     1, $NaN ],
+        ];
+
+    for my $t (@$T) {
+        print "# $t->[0] compile time\n";
+        my $a;
+        $w = '';
+        eval '$a = "'.$t->[0].'" + 1';
+        is("$a", "$t->[2]", "$t->[0] plus one is $t->[2]");
+        if ($t->[1]) {
+            like($w, qr/^Argument \Q"$t->[0]"\E isn't numeric/,
+                 "$t->[2] numify warn");
+        } else {
+            is($w, "", "no warning expected");
+        }
+        print "# $t->[0] runtime\n";
+        my $n = $t->[0];
+        my $b;
+        $w = '';
+        eval '$b = $n + 1';
+        is("$b", "$t->[2]", "$n plus one is $t->[2]");
+        if ($t->[1]) {
+            like($w, qr/^Argument \Q"$n"\E isn't numeric/,
+                 "$n numify warn");
+        } else {
+            is($w, "", "no warning expected");
+        }
+    }
+}
+
 done_testing();