Perl_sv_vcatpvfn_flags: %p and Inf/Nan

[perl5.git] / t / op / sprintf2.t

diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 568d4b5..c9cfdcf 100644 (file)
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -220,7 +220,7 @@ if ($Config{nvsize} == 8 &&
        [ '%a', '0.25',    '0x1p-2' ],
        [ '%a', '0.75',    '0x1.8p-1' ],
        [ '%a', '3.14',    '0x1.91eb851eb851eb851eb851eb85p+1' ],
-       [ '%a', '-1',      '-0x0p+0' ],
+       [ '%a', '-1',      '-0x1p+0' ],
        [ '%a', '-3.14',   '-0x1.91eb851eb851eb851eb851eb85p+1' ],
        [ '%a', '0.1',     '0x1.999999999999999999999999998p-4' ],
        [ '%a', '1/7',     '0x1.249249249249249249249249248p-3' ],
@@ -295,14 +295,6 @@ for my $i (1, 3, 5, 10) {
        "width & precision interplay with utf8 strings, length=$i");
 }
 
-# Used to mangle PL_sv_undef
-fresh_perl_like(
-    'print sprintf "xxx%n\n"; print undef',
-    qr/Modification of a read-only value attempted at\b/,
-    { switches => [ '-w' ] },
-    q(%n should not be able to modify read-only constants),
-);
-
 # check overflows
 for (int(~0/2+1), ~0, "9999999999999999999") {
     is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d");
@@ -528,10 +520,8 @@ for my $num (0, -1, 1) {
     }
 }
 
-my $vax_float = (pack("d", 1) =~ /^[\x80\x10]\x40/);
-
 SKIP: {
-    if ($vax_float) { skip "VAX float has no Inf or NaN", 3 }
+    unless ($Config{d_double_has_inf} && $Config{d_double_has_nan}) { skip "no Inf or NaN in doublekind $Config{doublekind}", 3 }
     # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383]
     foreach my $n ('2**1e100', '-2**1e100', '2**1e100/2**1e100') { # +Inf, -Inf, NaN
         eval { my $f = sprintf("%f", eval $n); };
@@ -600,7 +590,7 @@ is $o::count,    0, 'sprintf %d string overload count is 0';
 is $o::numcount, 1, 'sprintf %d number overload count is 1';
 
 SKIP: {  # hexfp
-    if ($vax_float) { skip "VAX float no hexfp", scalar @hexfloat }
+    unless ($Config{d_double_style_ieee}) { skip "no IEEE, no hexfp", scalar @hexfloat }
 
 my $ppc_linux = $Config{archname} =~ /^(?:ppc|power(?:pc)?)(?:64)?-linux/;
 my $irix_ld   = $Config{archname} =~ /^IP\d+-irix-ld$/;
@@ -696,8 +686,7 @@ SKIP: {
     skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef')
          . " longdblkind=$Config{longdblkind} os=$^O", 6)
         unless ($Config{uselongdouble} &&
-                ($Config{longdblkind} == 5 ||
-                 $Config{longdblkind} == 6)
+                ($Config{long_double_style_ieee_doubledouble})
                 # Gating on 'linux' (ppc) here is due to the differing
                 # double-double implementations: other (also big-endian)
                 # double-double platforms (e.g. AIX on ppc or IRIX on mips)
@@ -798,11 +787,15 @@ my @subnormals = (
 
 SKIP: {
     # [rt.perl.org #128843]
-    skip("non-IEEE-754-non-64-bit", scalar @subnormals + 34)
+    my $skip_count = scalar @subnormals + 34;
+    skip("non-IEEE-754-non-64-bit", $skip_count)
         unless ($Config{nvsize} == 8 &&
                $Config{nv_preserves_uv_bits} == 53 &&
                ($Config{doublekind} == 3 ||
                 $Config{doublekind} == 4));
+    if ($^O eq 'dec_osf') {
+        skip("$^O subnormals", $skip_count);
+    }
 
     for my $t (@subnormals) {
        # Note that "0x1p+2" is not considered numeric,
@@ -862,8 +855,7 @@ SKIP: {
     skip("non-80-bit-long-double", 17)
         unless ($Config{uselongdouble} &&
                ($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
-               ($Config{longdblkind} == 3 ||
-                $Config{longdblkind} == 4));
+               ($Config{long_double_style_ieee_extended}));
 
     {
         # The last normal for this format.
@@ -914,4 +906,75 @@ SKIP: {
     is(sprintf("%a", eval '0x1p-16494'), '0x1p-16494'); # underflow
 }
 
+# check all calls to croak_memory_wrap()
+# RT #131260
+
+{
+    my $s = 8 * $Config{sizesize};
+    my $i = 1;
+    my $max;
+    while ($s--) { $max |= $i; $i <<= 1; }
+
+    my @tests = (
+                  # format, arg
+                  ["%.${max}a",        1.1 ],
+                  ["%.${max}i",          1 ],
+                  ["%.${max}i",         -1 ],
+    );
+
+    for my $test (@tests) {
+        my ($fmt, $arg) = @$test;
+        eval { my $s = sprintf $fmt, $arg; };
+        like("$@", qr/panic: memory wrap/, qq{memory wrap: "$fmt", "$arg"});
+    }
+}
+
+{
+    # handle utf8 correctly when skipping invalid format
+    my $w_red   = 0;
+    my $w_inv   = 0;
+    my $w_other = 0;
+    local $SIG{__WARN__} = sub {
+        if ($_[0] =~ /^Invalid conversion/) {
+            $w_inv++;
+        }
+        elsif ($_[0] =~ /^Redundant argument/) {
+            $w_red++;
+        }
+        else {
+            $w_other++;
+        }
+    };
+
+    use warnings;
+    my $s = sprintf "%s%\xc4\x80%s", "\x{102}", "\xc4\x83";
+    is($s, "\x{102}%\xc4\x80\xc4\x83", "utf8 for invalid format");
+    is($w_inv,   1, "utf8 for invalid format: invalid warnings");
+    is($w_red,   0, "utf8 for invalid format: redundant warnings");
+    is($w_other, 0, "utf8 for invalid format: other warnings");
+}
+
+# it used to upgrade the result to utf8 if the 1st arg happened to be utf8
+
+{
+    my $precis = "9";
+    utf8::upgrade($precis);
+    my $s = sprintf "%.*f\n", $precis, 1.1;
+    ok(!utf8::is_utf8($s), "first arg not special utf8-wise");
+}
+
+# sprintf("%n") used to croak "Modification of a read-only value"
+# as it tried to set &PL_sv_no
+
+{
+    eval { my $s = sprintf("%n"); };
+    like $@, qr/Missing argument for %n in sprintf/, "%n";
+}
+
+# %p of an Inf or Nan address should still print its address, not
+# 'Inf' etc.
+
+like sprintf("%p", 0+'Inf'), qr/^[0-9a-f]+$/, "%p and Inf";
+like sprintf("%p", 0+'NaN'), qr/^[0-9a-f]+$/, "%p and NaN";
+
 done_testing();