1#!./perl -w 2 3# Tests for sprintf that do not fit the format of sprintf.t. 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8 set_up_inc('../lib'); 9 require './charset_tools.pl'; 10} 11 12# We'll run 12 extra tests (see below) if $Q is false. 13eval { my $q = pack "q", 0 }; 14my $Q = $@ eq ''; 15 16my $doubledouble; 17 18# %a and %A depend on the floating point config 19# This totally doesn't test non-IEEE-754 float formats. 20my @hexfloat; 21print "# uvsize = $Config{uvsize}\n"; 22print "# nvsize = $Config{nvsize}\n"; 23print "# nv_preserves_uv_bits = $Config{nv_preserves_uv_bits}\n"; 24print "# d_quad = $Config{d_quad}\n"; 25print "# uselongdouble = " . ($Config{uselongdouble} // 'undef') . "\n"; 26if ($Config{nvsize} == 8 && 27 ( 28 # IEEE-754 64-bit ("double precision"), the most common out there 29 ($Config{uvsize} == 8 && $Config{nv_preserves_uv_bits} == 53) 30 || 31 # If we have a quad we can still get the mantissa bits. 32 ($Config{uvsize} == 4 && $Config{d_quad}) 33 ) 34 ) { 35 @hexfloat = ( 36 [ '%a', '0', '0x0p+0' ], 37 [ '%a', '1', '0x1p+0' ], 38 [ '%a', '1.0', '0x1p+0' ], 39 [ '%a', '0.5', '0x1p-1' ], 40 [ '%a', '0.25', '0x1p-2' ], 41 [ '%a', '0.75', '0x1.8p-1' ], 42 [ '%a', '3.14', '0x1.91eb851eb851fp+1' ], 43 [ '%a', '-1.0', '-0x1p+0' ], 44 [ '%a', '-3.14', '-0x1.91eb851eb851fp+1' ], 45 [ '%a', '0.1', '0x1.999999999999ap-4' ], 46 [ '%a', '1/7', '0x1.2492492492492p-3' ], 47 [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcdp+0' ], 48 [ '%a', 'exp(1)', '0x1.5bf0a8b145769p+1' ], 49 [ '%a', '2**-10', '0x1p-10' ], 50 [ '%a', '2**10', '0x1p+10' ], 51 [ '%a', '1e-9', '0x1.12e0be826d695p-30' ], 52 [ '%a', '1e9', '0x1.dcd65p+29' ], 53 54 [ '%#a', '1', '0x1.p+0' ], 55 [ '%+a', '1', '+0x1p+0' ], 56 [ '%+a', '-1', '-0x1p+0' ], 57 [ '% a', ' 1', ' 0x1p+0' ], 58 [ '% a', '-1', '-0x1p+0' ], 59 60 [ '%+ a', '1', '+0x1p+0' ], 61 [ '%+ a', '-1', '-0x1p+0' ], 62 [ '% +a', ' 1', '+0x1p+0' ], 63 [ '% +a', '-1', '-0x1p+0' ], 64 65 [ '%8a', '3.14', '0x1.91eb851eb851fp+1' ], 66 [ '%13a', '3.14', '0x1.91eb851eb851fp+1' ], 67 [ '%20a', '3.14', '0x1.91eb851eb851fp+1' ], 68 [ '%.4a', '3.14', '0x1.91ecp+1' ], 69 [ '%.5a', '3.14', '0x1.91eb8p+1' ], 70 [ '%.6a', '3.14', '0x1.91eb85p+1' ], 71 [ '%.20a', '3.14', '0x1.91eb851eb851f0000000p+1' ], 72 [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], 73 [ '%20.15a', '3.14', '0x1.91eb851eb851f00p+1' ], 74 [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], 75 [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], 76 77 [ '%.13a', '1', '0x1.0000000000000p+0' ], 78 [ '%.13a', '-1', '-0x1.0000000000000p+0' ], 79 [ '%.13a', '0', '0x0.0000000000000p+0' ], 80 81 [ '%30a', '3.14', ' 0x1.91eb851eb851fp+1' ], 82 [ '%-30a', '3.14', '0x1.91eb851eb851fp+1 ' ], 83 [ '%030a', '3.14', '0x00000000001.91eb851eb851fp+1' ], 84 [ '%-030a', '3.14', '0x1.91eb851eb851fp+1 ' ], 85 86 [ '%.40a', '3.14', 87 '0x1.91eb851eb851f000000000000000000000000000p+1' ], 88 89 [ '%A', '3.14', '0X1.91EB851EB851FP+1' ], 90 ); 91} elsif (($Config{nvsize} == 16 || $Config{nvsize} == 12) && 92 # 80-bit ("extended precision") long double, pack F is the NV 93 # cd cc cc cc cc cc cc cc fb bf 00 00 00 00 00 00 94 # cd cc cc cc cc cc cc cc fb bf 00 00 95 (pack("F", 0.1) =~ /^\xCD/ || # LE 96 pack("F", 0.1) =~ /\xCD$/)) { # BE (if this ever happens) 97 @hexfloat = ( 98 [ '%a', '0', '0x0p+0' ], 99 [ '%a', '1', '0x8p-3' ], 100 [ '%a', '1.0', '0x8p-3' ], 101 [ '%a', '0.5', '0x8p-4' ], 102 [ '%a', '0.25', '0x8p-5' ], 103 [ '%a', '0.75', '0xcp-4' ], 104 [ '%a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], 105 [ '%a', '-1.0', '-0x8p-3' ], 106 [ '%a', '-3.14', '-0xc.8f5c28f5c28f5c3p-2' ], 107 [ '%a', '0.1', '0xc.ccccccccccccccdp-7' ], 108 [ '%a', '1/7', '0x9.249249249249249p-6' ], 109 [ '%a', 'sqrt(2)', '0xb.504f333f9de6484p-3' ], 110 [ '%a', 'exp(1)', '0xa.df85458a2bb4a9bp-2' ], 111 [ '%a', '2**-10', '0x8p-13' ], 112 [ '%a', '2**10', '0x8p+7' ], 113 [ '%a', '1e-9', '0x8.9705f4136b4a597p-33' ], 114 [ '%a', '1e9', '0xe.e6b28p+26' ], 115 116 [ '%#a', '1', '0x8.p-3' ], 117 [ '%+a', '1', '+0x8p-3' ], 118 [ '%+a', '-1', '-0x8p-3' ], 119 [ '% a', ' 1', ' 0x8p-3' ], 120 [ '% a', '-1', '-0x8p-3' ], 121 122 [ '%+ a', '1', '+0x8p-3' ], 123 [ '%+ a', '-1', '-0x8p-3' ], 124 [ '% +a', ' 1', '+0x8p-3' ], 125 [ '% +a', '-1', '-0x8p-3' ], 126 127 [ '%8a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], 128 [ '%13a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], 129 [ '%20a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], 130 [ '%.4a', '3.14', '0xc.8f5cp-2' ], 131 [ '%.5a', '3.14', '0xc.8f5c3p-2' ], 132 [ '%.6a', '3.14', '0xc.8f5c29p-2' ], 133 [ '%.20a', '3.14', '0xc.8f5c28f5c28f5c300000p-2' ], 134 [ '%20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], 135 [ '%20.15a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], 136 [ '% 20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], 137 [ '%020.10a', '3.14', '0x000c.8f5c28f5c3p-2' ], 138 139 [ '%30a', '3.14', ' 0xc.8f5c28f5c28f5c3p-2' ], 140 [ '%-30a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], 141 [ '%030a', '3.14', '0x00000000c.8f5c28f5c28f5c3p-2' ], 142 [ '%-030a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], 143 144 [ '%.40a', '3.14', 145 '0xc.8f5c28f5c28f5c30000000000000000000000000p-2' ], 146 147 [ '%A', '3.14', '0XC.8F5C28F5C28F5C3P-2' ], 148 ); 149} elsif ( 150 # IEEE 754 128-bit ("quadruple precision"), e.g. IA-64 (Itanium) in VMS 151 $Config{nvsize} == 16 && 152 # 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f (LE), pack F is the NV 153 (pack("F", 0.1) =~ /^\x9A\x99{6}/ || # LE 154 pack("F", 0.1) =~ /\x99{6}\x9A$/) # BE 155 ) { 156 @hexfloat = ( 157 [ '%a', '0', '0x0p+0' ], 158 [ '%a', '1', '0x1p+0' ], 159 [ '%a', '1.0', '0x1p+0' ], 160 [ '%a', '0.5', '0x1p-1' ], 161 [ '%a', '0.25', '0x1p-2' ], 162 [ '%a', '0.75', '0x1.8p-1' ], 163 [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 164 [ '%a', '-1', '-0x1p+0' ], 165 [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb851fp+1' ], 166 [ '%a', '0.1', '0x1.999999999999999999999999999ap-4' ], 167 [ '%a', '1/7', '0x1.2492492492492492492492492492p-3' ], 168 [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea95p+0' ], 169 [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e7ap+1' ], 170 [ '%a', '2**-10', '0x1p-10' ], 171 [ '%a', '2**10', '0x1p+10' ], 172 [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f12ap-30' ], 173 [ '%a', '1e9', '0x1.dcd65p+29' ], 174 175 [ '%#a', '1', '0x1.p+0' ], 176 [ '%+a', '1', '+0x1p+0' ], 177 [ '%+a', '-1', '-0x1p+0' ], 178 [ '% a', '1', ' 0x1p+0' ], 179 [ '% a', '-1', '-0x1p+0' ], 180 181 [ '%+ a', '1', '+0x1p+0' ], 182 [ '%+ a', '-1', '-0x1p+0' ], 183 [ '% +a', ' 1', '+0x1p+0' ], 184 [ '% +a', '-1', '-0x1p+0' ], 185 186 [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 187 [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 188 [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 189 [ '%.4a', '3.14', '0x1.91ecp+1' ], 190 [ '%.5a', '3.14', '0x1.91eb8p+1' ], 191 [ '%.6a', '3.14', '0x1.91eb85p+1' ], 192 [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], 193 [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], 194 [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], 195 [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], 196 [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], 197 198 [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 199 [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 200 [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 201 [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], 202 203 [ '%.40a', '3.14', 204 '0x1.91eb851eb851eb851eb851eb851f000000000000p+1' ], 205 206 [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB851FP+1' ], 207 ); 208} elsif ( 209 # "double-double", two 64-bit doubles end to end 210 $Config{nvsize} == 16 && 211 # bf b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE), pack F is the NV 212 (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ || # LE 213 pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/) # BE 214 ) { 215 $doubledouble = 1; 216 @hexfloat = ( 217 [ '%a', '0', '0x0p+0' ], 218 [ '%a', '1', '0x1p+0' ], 219 [ '%a', '1.0', '0x1p+0' ], 220 [ '%a', '0.5', '0x1p-1' ], 221 [ '%a', '0.25', '0x1p-2' ], 222 [ '%a', '0.75', '0x1.8p-1' ], 223 [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 224 [ '%a', '-1', '-0x1p+0' ], 225 [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb85p+1' ], 226 [ '%a', '0.1', '0x1.999999999999999999999999998p-4' ], 227 [ '%a', '1/7', '0x1.249249249249249249249249248p-3' ], 228 [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea8p+0' ], 229 [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e8p+1' ], 230 [ '%a', '2**-10', '0x1p-10' ], 231 [ '%a', '2**10', '0x1p+10' ], 232 [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f14p-30' ], 233 [ '%a', '1e9', '0x1.dcd65p+29' ], 234 235 [ '%#a', '1', '0x1.p+0' ], 236 [ '%+a', '1', '+0x1p+0' ], 237 [ '%+a', '-1', '-0x1p+0' ], 238 [ '% a', '1', ' 0x1p+0' ], 239 [ '% a', '-1', '-0x1p+0' ], 240 241 [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 242 [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 243 [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 244 [ '%.4a', '3.14', '0x1.91ecp+1' ], 245 [ '%.5a', '3.14', '0x1.91eb8p+1' ], 246 [ '%.6a', '3.14', '0x1.91eb85p+1' ], 247 [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], 248 [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], 249 [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], 250 [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], 251 [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], 252 253 [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 254 [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 255 [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 256 [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], 257 258 [ '%.40a', '3.14', 259 '0x1.91eb851eb851eb851eb851eb8500000000000000p+1' ], 260 261 [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB85P+1' ], 262 ); 263} else { 264 print "# no hexfloat tests\n"; 265} 266 267use strict; 268use Config; 269 270is( 271 sprintf("%.40g ",0.01), 272 sprintf("%.40g", 0.01)." ", 273 q(the sprintf "%.<number>g" optimization) 274); 275is( 276 sprintf("%.40f ",0.01), 277 sprintf("%.40f", 0.01)." ", 278 q(the sprintf "%.<number>f" optimization) 279); 280 281# cases of $i > 1 are against [perl #39126] 282for my $i (1, 5, 10, 20, 50, 100) { 283 chop(my $utf8_format = "%-*s\x{100}"); 284 my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT 285 my $expect = $string." "x$i; # followed by 2*$i spaces 286 is(sprintf($utf8_format, 3*$i, $string), $expect, 287 "width calculation under utf8 upgrade, length=$i"); 288} 289 290# check simultaneous width & precision with wide characters 291for my $i (1, 3, 5, 10) { 292 my $string = "\x{0410}"x($i+10); # cyrillic capital A 293 my $expect = "\x{0410}"x$i; # cut down to exactly $i characters 294 my $format = "%$i.${i}s"; 295 is(sprintf($format, $string), $expect, 296 "width & precision interplay with utf8 strings, length=$i"); 297} 298 299# check overflows 300for (int(~0/2+1), ~0, "9999999999999999999") { 301 is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d"); 302 like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf"); 303 is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d"); 304 like($@, qr/^Integer overflow in format string for printf /, "overflow in printf"); 305} 306 307# check %NNN$ for range bounds 308{ 309 my ($warn, $bad) = (0,0); 310 local $SIG{__WARN__} = sub { 311 if ($_[0] =~ /missing argument/i) { 312 $warn++ 313 } 314 else { 315 $bad++ 316 } 317 }; 318 319 for my $i (1..20) { 320 my @args = qw(a b c d); 321 my $result = sprintf "%$i\$s", @args; 322 is $result, $args[$i-1]//"", "%NNN\$s where NNN=$i"; 323 my $j = ~$i; 324 $result = eval { sprintf "%$j\$s", @args; }; 325 like $@, qr/Integer overflow/ , "%NNN\$s where NNN=~$i"; 326 } 327 328 is($warn, 16, "expected warnings"); 329 is($bad, 0, "unexpected warnings"); 330} 331 332# Tests for "missing argument" and "redundant argument" warnings 333{ 334 my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); 335 local $SIG{__WARN__} = sub { 336 if ($_[0] =~ /missing argument/i) { 337 $warn_missing++ 338 } 339 elsif ($_[0] =~ /redundant argument/i) { 340 $warn_redundant++ 341 } 342 else { 343 $warn_bad++ 344 } 345 }; 346 347 my @tests = ( 348 # The "", "%s", and "%-p" formats have special-case handling 349 # in sv.c 350 { 351 fmt => "", 352 args => [ qw( x ) ], 353 res => "", 354 m => 0, 355 r => 1, 356 }, 357 { 358 fmt => "%s", 359 args => [ qw( x y ) ], 360 res => "x", 361 m => 0, 362 r => 1, 363 }, 364 { 365 fmt => "%-p", 366 args => [ qw( x y ) ], 367 res => qr/^[0-9a-f]+$/as, 368 m => 0, 369 r => 1, 370 }, 371 # Other non-specialcased patterns 372 { 373 fmt => "%s : %s", 374 args => [ qw( a b c ) ], 375 res => "a : b", 376 m => 0, 377 r => 1, 378 }, 379 { 380 fmt => "%s : %s : %s", 381 args => [ qw( a b c d e ) ], 382 res => "a : b : c", 383 m => 0, 384 # Note how we'll only warn about redundant arguments once, 385 # even though both "d" and "e" are redundant... 386 r => 1, 387 }, 388 { 389 fmt => "%s : %s : %s", 390 args => [ ], 391 res => " : : ", 392 # ...But when arguments are missing we'll warn about every 393 # missing argument. This difference between the two 394 # warnings is a feature. 395 m => 3, 396 r => 0, 397 }, 398 399 # Tests for format parameter indexes. 400 # 401 # Deciding what to do about these is a bit tricky, and so is 402 # "correctly" warning about missing arguments on them. 403 # 404 # Should we warn if you supply 4 arguments but only use 405 # argument 1,3 & 4? Or only if you supply 5 arguments and your 406 # highest used argument is 4? 407 # 408 # For some uses of this printf feature (e.g. i18n systems) 409 # it's a always a logic error to not print out every provided 410 # argument, but for some other uses skipping some might be a 411 # feature (although you could argue that then printf should be 412 # called as e.g: 413 # 414 # printf q[%1$s %3$s], x(), undef, z(); 415 # 416 # Instead of: 417 # 418 # printf q[%1$s %3$s], x(), y(), z(); 419 # 420 # Since calling the (possibly expensive) y() function is 421 # completely redundant there. 422 # 423 # We deal with all these potential problems by not even 424 # trying. If the pattern contains any format parameter indexes 425 # whatsoever we'll never warn about redundant arguments. 426 { 427 fmt => '%1$s : %2$s', 428 args => [ qw( x y z ) ], 429 res => "x : y", 430 m => 0, 431 r => 0, 432 }, 433 { 434 fmt => '%2$s : %4$s : %5$s', 435 args => [ qw( a b c d )], 436 res => "b : d : ", 437 m => 1, 438 r => 0, 439 }, 440 { 441 fmt => '%s : %1$s : %s', 442 args => [ qw( x y z ) ], 443 res => "x : x : y", 444 m => 0, 445 r => 0, 446 }, 447 448 ); 449 450 for my $i (0..$#tests) { 451 my $test = $tests[$i]; 452 my $result = sprintf $test->{fmt}, @{$test->{args}}; 453 454 my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'"; 455 if (ref $test->{res} eq 'Regexp') { 456 like($result, $test->{res}, "$prefix got the right result"); 457 } else { 458 is($result, $test->{res}, "$prefix got the right result"); 459 } 460 is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings"); 461 is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings"); 462 is($warn_bad, 0, "$prefix No unknown warnings"); 463 464 ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); 465 } 466} 467 468{ 469 foreach my $ord (0 .. 255) { 470 my $bad = 0; 471 local $SIG{__WARN__} = sub { 472 if ( $_[0] !~ /^Invalid conversion in sprintf/ 473 && $_[0] !~ /^Missing argument in sprintf/ ) 474 { 475 warn $_[0]; 476 $bad++; 477 } 478 }; 479 my $r = eval {sprintf '%v' . chr $ord}; 480 is ($bad, 0, "pattern '%v' . chr $ord"); 481 } 482} 483 484sub mysprintf_int_flags { 485 my ($fmt, $num) = @_; 486 die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/; 487 my $flag = $1; 488 my $width = $2; 489 my $sign = $num < 0 ? '-' : 490 $flag =~ /\+/ ? '+' : 491 $flag =~ /\ / ? ' ' : 492 ''; 493 my $abs = abs($num); 494 my $padlen = $width - length($sign.$abs); 495 return 496 $flag =~ /0/ && $flag !~ /-/ # do zero padding 497 ? $sign . '0' x $padlen . $abs 498 : $flag =~ /-/ # left or right 499 ? $sign . $abs . ' ' x $padlen 500 : ' ' x $padlen . $sign . $abs; 501} 502 503# Whole tests for "%4d" with 2 to 4 flags; 504# total counts: 3 * (4**2 + 4**3 + 4**4) == 1008 505 506my @flags = ("-", "+", " ", "0"); 507for my $num (0, -1, 1) { 508 for my $f1 (@flags) { 509 for my $f2 (@flags) { 510 for my $f3 ('', @flags) { # '' for doubled flags 511 my $flag = $f1.$f2.$f3; 512 my $width = 4; 513 my $fmt = '%'."${flag}${width}d"; 514 my $result = sprintf($fmt, $num); 515 my $expect = mysprintf_int_flags($fmt, $num); 516 is($result, $expect, qq/sprintf("$fmt",$num)/); 517 518 next if $f3 eq ''; 519 520 for my $f4 (@flags) { # quadrupled flags 521 my $flag = $f1.$f2.$f3.$f4; 522 my $fmt = '%'."${flag}${width}d"; 523 my $result = sprintf($fmt, $num); 524 my $expect = mysprintf_int_flags($fmt, $num); 525 is($result, $expect, qq/sprintf("$fmt",$num)/); 526 } 527 } 528 } 529 } 530} 531 532SKIP: { 533 unless ($Config{d_double_has_inf} && $Config{d_double_has_nan}) { skip "no Inf or NaN in doublekind $Config{doublekind}", 3 } 534 # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] 535 foreach my $n ('2**1e100', '-2**1e100', '2**1e100/2**1e100') { # +Inf, -Inf, NaN 536 eval { my $f = sprintf("%f", eval $n); }; 537 is $@, "", "sprintf(\"%f\", $n)"; 538 } 539} 540 541# test %ll formats with and without HAS_QUAD 542my @tests = ( 543 [ '%lld' => [qw( 4294967296 -100000000000000 )] ], 544 [ '%lli' => [qw( 4294967296 -100000000000000 )] ], 545 [ '%llu' => [qw( 4294967296 100000000000000 )] ], 546 [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], 547 [ '%Li' => [qw( 4294967296 -100000000000000 )] ], 548 [ '%Lu' => [qw( 4294967296 100000000000000 )] ], 549); 550 551for my $t (@tests) { 552 my($fmt, $nums) = @$t; 553 for my $num (@$nums) { 554 my $w = ''; 555 local $SIG{__WARN__} = sub { $w .= shift }; 556 my $sprintf_got = sprintf($fmt, $num); 557 if ($Q) { 558 is($sprintf_got, $num, "quad: $fmt -> $num"); 559 is($w, '', "no warnings for: $fmt -> $num"); 560 } else { 561 is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt"); 562 like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt"); 563 } 564 } 565} 566 567# Check unicode vs byte length 568for my $width (1,2,3,4,5,6,7) { 569 for my $precis (1,2,3,4,5,6,7) { 570 my $v = "\x{20ac}\x{20ac}"; 571 my $format = "%" . $width . "." . $precis . "s"; 572 my $chars = ($precis > 2 ? 2 : $precis); 573 my $space = ($width < 2 ? 0 : $width - $chars); 574 fresh_perl_is( 575 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', 576 "$space$chars", 577 {}, 578 q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), 579 ); 580 } 581} 582 583# Overload count 584package o { 585 use overload 586 '""', sub { ++our $count; $_[0][0]; }, 587 '0+', sub { ++our $numcount; $_[0][1]; } 588} 589my $o = bless ["\x{100}",42], o::; 590() = sprintf "%1s", $o; 591is $o::count, '1', 'sprinf %1s overload count'; 592$o::count = 0; 593() = sprintf "%.1s", $o; 594is $o::count, '1', 'sprinf %.1s overload count'; 595$o::count = 0; 596() = sprintf "%d", $o; 597is $o::count, 0, 'sprintf %d string overload count is 0'; 598is $o::numcount, 1, 'sprintf %d number overload count is 1'; 599 600SKIP: { # hexfp 601 unless ($Config{d_double_style_ieee}) { skip "no IEEE, no hexfp", scalar @hexfloat } 602 603my $ppc_linux = $Config{archname} =~ /^(?:ppc|power(?:pc)?)(?:64)?-linux/; 604my $irix_ld = $Config{archname} =~ /^IP\d+-irix-ld$/; 605 606for my $t (@hexfloat) { 607 my ($format, $arg, $expected) = @$t; 608 $arg = eval $arg; 609 my $result = sprintf($format, $arg); 610 my $ok = $result eq $expected; 611 # For certain platforms (all of which are currently double-double, 612 # but different implementations, GNU vs vendor, two different archs 613 # (ppc and mips), and two different libm interfaces) we have some 614 # bits-in-the-last-hexdigit differences. 615 # Patch them up as TODOs instead of deadly errors. 616 if ($doubledouble && $ppc_linux && $arg =~ /^2.71828/) { 617 # gets '0x1.5bf0a8b1457695355fb8ac404ecp+1' 618 # wants '0x1.5bf0a8b1457695355fb8ac404e8p+1' 619 local $::TODO = "$Config{archname} exp(1)"; 620 ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); 621 next; 622 } 623 if ($doubledouble && $irix_ld && $arg =~ /^1.41421/) { 624 # gets '0x1.6a09e667f3bcc908b2fb1366eacp+0' 625 # wants '0x1.6a09e667f3bcc908b2fb1366ea8p+0' 626 local $::TODO = "$Config{archname} sqrt(2)"; 627 ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); 628 next; 629 } 630 if (!$ok && $result =~ /\./ && $expected =~ /\./) { 631 # It seems that there can be difference in the last bits: 632 # [perl #122578] 633 # got "0x1.5bf0a8b14576ap+1" 634 # expected "0x1.5bf0a8b145769p+1" 635 # (Android on ARM) 636 # 637 # Exact cause unknown but suspecting different fp rounding modes, 638 # (towards zero? towards +inf? towards -inf?) about which Perl 639 # is blissfully unaware. 640 # 641 # Try extracting one (or sometimes two) last mantissa 642 # hexdigits, and see if they differ in value by one. 643 my ($rh, $eh) = ($result, $expected); 644 sub extract_prefix { 645 ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1; 646 } 647 my $rp = extract_prefix($rh); 648 my $ep = extract_prefix($eh); 649 print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n"; 650 if ($rp eq $ep) { # If prefixes match. 651 sub extract_exponent { 652 ($_[0] =~ s/([pP][+-]?\d+)//) && return $1; 653 } 654 my $re = extract_exponent($rh); 655 my $ee = extract_exponent($eh); 656 print "# re = $re, ee = $ee (rh $rh, eh $eh)\n"; 657 if ($re eq $ee) { # If exponents match. 658 # Remove the common prefix of the mantissa bits. 659 my $la = length($rh); 660 my $lb = length($eh); 661 my $i; 662 for ($i = 0; $i < $la && $i < $lb; $i++) { 663 last if substr($rh, $i, 1) ne substr($eh, $i, 1); 664 } 665 $rh = substr($rh, $i); 666 $eh = substr($eh, $i); 667 print "# (rh $rh, eh $eh)\n"; 668 if ($rh ne $eh) { 669 # If necessary, pad the shorter one on the right 670 # with one zero (for example "...1f" vs "...2", 671 # we want to compare "1f" to "20"). 672 if (length $rh < length $eh) { 673 $rh .= '0'; 674 } elsif (length $eh < length $rh) { 675 $eh .= '0'; 676 } 677 print "# (rh $rh, eh $eh)\n"; 678 if (length $eh == length $rh) { 679 if (abs(hex($eh) - hex($rh)) == 1) { 680 $ok = 1; 681 } 682 } 683 } 684 } 685 } 686 } 687 if (!$ok && $^O eq "netbsd" && $t->[1] eq "exp(1)") { 688 SKIP: 689 { 690 skip "NetBSD's expl() is just exp() in disguise", 1; 691 } 692 next; 693 } 694 ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); 695} 696 697} # SKIP: # hexfp 698 699# double-double long double %a special testing. 700SKIP: { 701 skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef') 702 . " longdblkind=$Config{longdblkind} os=$^O", 6) 703 unless ($Config{uselongdouble} && 704 ($Config{d_long_double_style_ieee_doubledouble}) 705 # Gating on 'linux' (ppc) here is due to the differing 706 # double-double implementations: other (also big-endian) 707 # double-double platforms (e.g. AIX on ppc or IRIX on mips) 708 # do not behave similarly. 709 && $^O eq 'linux' 710 ); 711 # [rt.perl.org 125633] 712 like(sprintf("%La\n", eval '(2**1020) + (2**-1072)'), 713 qr/^0x1.0{522}1p\+1020$/); 714 like(sprintf("%La\n", eval '(2**1021) + (2**-1072)'), 715 qr/^0x1.0{523}8p\+1021$/); 716 like(sprintf("%La\n", eval '(2**1022) + (2**-1072)'), 717 qr/^0x1.0{523}4p\+1022$/); 718 like(sprintf("%La\n", eval '(2**1023) + (2**-1072)'), 719 qr/^0x1.0{523}2p\+1023$/); 720 like(sprintf("%La\n", eval '(2**1023) + (2**-1073)'), 721 qr/^0x1.0{523}1p\+1023$/); 722 like(sprintf("%La\n", eval '(2**1023) + (2**-1074)'), 723 qr/^0x1.0{524}8p\+1023$/); 724} 725 726SKIP: { 727 skip("negative zero not available\n", 3) 728 unless sprintf('%+f', -0.0) =~ /^-0/; 729 is(sprintf("%a", -0.0), "-0x0p+0", "negative zero"); 730 is(sprintf("%+a", -0.0), "-0x0p+0", "negative zero"); 731 is(sprintf("%.13a", -0.0), "-0x0.0000000000000p+0", "negative zero"); 732} 733 734SKIP: { 735 # [perl #127183] Non-canonical hexadecimal floats are parsed prematurely 736 737 # IEEE 754 64-bit 738 skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53", 3) 739 unless $Config{nv_preserves_uv_bits} == 53; 740 741 { 742 # The 0x0.b17217f7d1cf78p0 is the original LHS value 743 # from [perl #127183], its bits are 0x162e42fefa39ef << 3, 744 # resulting in a non-canonical form of hexfp, where the most 745 # significant bit is zero, instead of one. 746 is(sprintf("%a", 0x0.b17217f7d1cf78p0 - 0x1.62e42fefa39efp-1), 747 "0x0p+0", 748 "non-canonical form [perl #127183]"); 749 } 750 751 { 752 no warnings 'overflow'; # Not the point here. 753 754 # The 0x058b90bfbe8e7bc is 0x162e42fefa39ef << 2, 755 # the 0x02c5c85fdf473de is 0x162e42fefa39ef << 1, 756 # see above. 757 is(sprintf("%a", 0x0.58b90bfbe8e7bcp1 - 0x1.62e42fefa39efp-1), 758 "0x0p+0", 759 "non-canonical form"); 760 761 is(sprintf("%a", 0x0.2c5c85fdf473dep2 - 0x1.62e42fefa39efp-1), 762 "0x0p+0", 763 "non-canonical form"); 764 } 765} 766 767# These are IEEE 754 64-bit subnormals (formerly known as denormals). 768# Keep these as strings so that non-IEEE-754 don't trip over them. 769my @subnormals = ( 770 [ '1e-320', '%a', '0x1.fap-1064' ], 771 [ '1e-321', '%a', '0x1.94p-1067' ], 772 [ '1e-322', '%a', '0x1.4p-1070' ], 773 [ '1e-323', '%a', '0x1p-1073' ], 774 [ '1e-324', '%a', '0x0p+0' ], # underflow 775 [ '3e-320', '%a', '0x1.7b8p-1062' ], 776 [ '3e-321', '%a', '0x1.2f8p-1065' ], 777 [ '3e-322', '%a', '0x1.e8p-1069' ], 778 [ '3e-323', '%a', '0x1.8p-1072' ], 779 [ '3e-324', '%a', '0x1p-1074' ], # the smallest possible value 780 [ '7e-320', '%a', '0x1.bacp-1061' ], 781 [ '7e-321', '%a', '0x1.624p-1064' ], 782 [ '7e-322', '%a', '0x1.1cp-1067' ], 783 [ '7e-323', '%a', '0x1.cp-1071' ], 784 [ '7e-324', '%a', '0x1p-1074' ], # the smallest possible value, again 785 [ '3e-320', '%.4a', '0x1.7b80p-1062' ], 786 [ '3e-321', '%.4a', '0x1.2f80p-1065' ], 787 [ '3e-322', '%.4a', '0x1.e800p-1069' ], 788 [ '3e-323', '%.4a', '0x1.8000p-1072' ], 789 [ '3e-324', '%.4a', '0x1.0000p-1074' ], 790 [ '3e-320', '%.1a', '0x1.8p-1062' ], 791 [ '3e-321', '%.1a', '0x1.3p-1065' ], 792 [ '3e-322', '%.1a', '0x1.ep-1069' ], 793 [ '3e-323', '%.1a', '0x1.8p-1072' ], 794 [ '3e-324', '%.1a', '0x1.0p-1074' ], 795 [ '0x1.fffffffffffffp-1022', '%a', '0x1.fffffffffffffp-1022' ], 796 [ '0x0.fffffffffffffp-1022', '%a', '0x1.ffffffffffffep-1023' ], 797 [ '0x0.7ffffffffffffp-1022', '%a', '0x1.ffffffffffffcp-1024' ], 798 [ '0x0.3ffffffffffffp-1022', '%a', '0x1.ffffffffffff8p-1025' ], 799 [ '0x0.1ffffffffffffp-1022', '%a', '0x1.ffffffffffffp-1026' ], 800 [ '0x0.0ffffffffffffp-1022', '%a', '0x1.fffffffffffep-1027' ], 801 ); 802 803SKIP: { 804 # [rt.perl.org #128843] 805 my $skip_count = scalar @subnormals + 34; 806 skip("non-IEEE-754-non-64-bit", $skip_count) 807 unless ($Config{nvsize} == 8 && 808 $Config{nv_preserves_uv_bits} == 53 && 809 ($Config{doublekind} == 3 || 810 $Config{doublekind} == 4)); 811 if ($^O eq 'dec_osf') { 812 skip("$^O subnormals", $skip_count); 813 } 814 815 for my $t (@subnormals) { 816 # Note that "0x1p+2" is not considered numeric, 817 # since neither is "0x12", hence the eval. 818 my $f = eval $t->[0]; 819 # XXX under g++ -ansi, pow(2.0, -1074) returns 0 rather 820 # than the smallest denorm number. Which means that very small 821 # string literals on a perl compiled under g++ may be seen as 0. 822 # This is either a bug in the g++ math library or scan_num() in 823 # toke.c; but in either case, its not a bug in sprintf(), so 824 # skip the test. 825 local $::TODO = "denorm literals treated as zero" 826 if $f == 0.0 && $t->[2] ne '0x0p+0'; 827 828 # Versions of Visual C++ earlier than 2015 (VC14, cl.exe version 19.x) 829 # fail three tests here - see perl #133982. 830 local $::TODO = "Visual C++ has problems prior to VC14" 831 if $^O eq 'MSWin32' and $Config{cc} eq 'cl' and 832 $Config{ccversion} =~ /^(\d+)/ and $1 < 19 and 833 (($t->[0] eq '3e-322' and ($t->[1] eq '%a' or $t->[1] eq '%.4a')) or 834 $t->[0] eq '7e-322'); 835 836 my $s = sprintf($t->[1], $f); 837 is($s, $t->[2], "subnormal @$t got $s"); 838 } 839 840 # [rt.perl.org #128888] 841 is(sprintf("%a", 1.03125), "0x1.08p+0"); 842 is(sprintf("%.1a", 1.03125), "0x1.0p+0"); 843 is(sprintf("%.0a", 1.03125), "0x1p+0", "[rt.perl.org #128888]"); 844 845 # [rt.perl.org #128889] 846 is(sprintf("%.*a", -1, 1.03125), "0x1.08p+0", "[rt.perl.org #128889]"); 847 848 # [rt.perl.org #134008] 849 is(sprintf("%.*a", -99999, 1.03125), "0x1.08p+0", "[rt.perl.org #134008]"); 850 is(sprintf("%.*a", -100000,0), "0x0p+0", "negative precision ignored by format_hexfp"); 851 852 # [rt.perl.org #128890] 853 is(sprintf("%a", 0x1.18p+0), "0x1.18p+0"); 854 is(sprintf("%.1a", 0x1.08p+0), "0x1.0p+0"); 855 is(sprintf("%.1a", 0x1.18p+0), "0x1.2p+0", "[rt.perl.org #128890]"); 856 is(sprintf("%.1a", 0x1.28p+0), "0x1.2p+0"); 857 is(sprintf("%.1a", 0x1.38p+0), "0x1.4p+0"); 858 is(sprintf("%.1a", 0x1.48p+0), "0x1.4p+0"); 859 is(sprintf("%.1a", 0x1.58p+0), "0x1.6p+0"); 860 is(sprintf("%.1a", 0x1.68p+0), "0x1.6p+0"); 861 is(sprintf("%.1a", 0x1.78p+0), "0x1.8p+0"); 862 is(sprintf("%.1a", 0x1.88p+0), "0x1.8p+0"); 863 is(sprintf("%.1a", 0x1.98p+0), "0x1.ap+0"); 864 is(sprintf("%.1a", 0x1.a8p+0), "0x1.ap+0"); 865 is(sprintf("%.1a", 0x1.b8p+0), "0x1.cp+0"); 866 is(sprintf("%.1a", 0x1.c8p+0), "0x1.cp+0"); 867 is(sprintf("%.1a", 0x1.d8p+0), "0x1.ep+0"); 868 is(sprintf("%.1a", 0x1.e8p+0), "0x1.ep+0"); 869 is(sprintf("%.1a", 0x1.f8p+0), "0x2.0p+0"); 870 871 is(sprintf("%.1a", 0x1.10p+0), "0x1.1p+0"); 872 is(sprintf("%.1a", 0x1.17p+0), "0x1.1p+0"); 873 is(sprintf("%.1a", 0x1.19p+0), "0x1.2p+0"); 874 is(sprintf("%.1a", 0x1.1fp+0), "0x1.2p+0"); 875 876 is(sprintf("%.2a", 0x1.fffp+0), "0x2.00p+0"); 877 is(sprintf("%.2a", 0xf.fffp+0), "0x2.00p+3"); 878 879 # [rt.perl.org #128893] 880 is(sprintf("%020a", 1.5), "0x0000000000001.8p+0"); 881 is(sprintf("%020a", -1.5), "-0x000000000001.8p+0", "[rt.perl.org #128893]"); 882 is(sprintf("%+020a", 1.5), "+0x000000000001.8p+0", "[rt.perl.org #128893]"); 883 is(sprintf("% 020a", 1.5), " 0x000000000001.8p+0", "[rt.perl.org #128893]"); 884 is(sprintf("%20a", -1.5), " -0x1.8p+0"); 885 is(sprintf("%+20a", 1.5), " +0x1.8p+0"); 886 is(sprintf("% 20a", 1.5), " 0x1.8p+0"); 887} 888 889# x86 80-bit long-double tests for 890# rt.perl.org #128843, #128888, #128889, #128890, #128893, #128909 891SKIP: { 892 skip("non-80-bit-long-double", 17) 893 unless ($Config{uselongdouble} && 894 ($Config{nvsize} == 16 || $Config{nvsize} == 12) && 895 ($Config{d_long_double_style_ieee_extended})); 896 897 { 898 # The last normal for this format. 899 is(sprintf("%a", eval '0x1p-16382'), "0x8p-16385", "[rt.perl.org #128843]"); 900 901 # The subnormals cause "exponent underflow" warnings, 902 # but that is not why we are here. 903 local $SIG{__WARN__} = sub { 904 die "$0: $_[0]" unless $_[0] =~ /exponent underflow/; 905 }; 906 907 is(sprintf("%a", eval '0x1p-16383'), "0x4p-16382", "[rt.perl.org #128843]"); 908 is(sprintf("%a", eval '0x1p-16384'), "0x2p-16382", "[rt.perl.org #128843]"); 909 is(sprintf("%a", eval '0x1p-16385'), "0x1p-16382", "[rt.perl.org #128843]"); 910 is(sprintf("%a", eval '0x1p-16386'), "0x8p-16386", "[rt.perl.org #128843]"); 911 is(sprintf("%a", eval '0x1p-16387'), "0x4p-16386", "[rt.perl.org #128843]"); 912 } 913 is(sprintf("%.0a", 1.03125), "0x8p-3", "[rt.perl.org #128888]"); 914 is(sprintf("%.*a", -1, 1.03125), "0x8.4p-3", "[rt.perl.org #128889]"); 915 is(sprintf("%.1a", 0x8.18p+0), "0x8.2p+0", "[rt.perl.org #128890]"); 916 is(sprintf("%020a", -1.5), "-0x0000000000000cp-3", "[rt.perl.org #128893]"); 917 is(sprintf("%+020a", 1.5), "+0x0000000000000cp-3", "[rt.perl.org #128893]"); 918 is(sprintf("% 020a", 1.5), " 0x0000000000000cp-3", "[rt.perl.org #128893]"); 919 is(sprintf("%a", 1.9999999999999999999), "0xf.fffffffffffffffp-3"); 920 is(sprintf("%.3a", 1.9999999999999999999), "0x1.000p+1", "[rt.perl.org #128909]"); 921 is(sprintf("%.2a", 1.9999999999999999999), "0x1.00p+1"); 922 is(sprintf("%.1a", 1.9999999999999999999), "0x1.0p+1"); 923 is(sprintf("%.0a", 1.9999999999999999999), "0x1p+1"); 924} 925 926# quadmath tests for rt.perl.org #128843 927SKIP: { 928 skip "need quadmath", 7, unless $Config{usequadmath}; 929 930 is(sprintf("%a", eval '0x1p-16382'), '0x1p-16382'); # last normal 931 932 local $SIG{__WARN__} = sub { 933 die "$0: $_[0]" unless $_[0] =~ /exponent underflow/; 934 }; 935 936 is(sprintf("%a", eval '0x1p-16383'), '0x1p-16383'); 937 is(sprintf("%a", eval '0x1p-16384'), '0x1p-16384'); 938 939 is(sprintf("%a", eval '0x1p-16491'), '0x1p-16491'); 940 is(sprintf("%a", eval '0x1p-16492'), '0x1p-16492'); 941 is(sprintf("%a", eval '0x1p-16493'), '0x1p-16493'); # last denormal 942 943 is(sprintf("%a", eval '0x1p-16494'), '0x1p-16494'); # underflow 944} 945 946# check all calls to croak_memory_wrap() 947# RT #131260 948# (these now fail earlier with "Integer overflow" rather than 949# "memory wrap" - DAPM) 950 951{ 952 my $s = 8 * $Config{sizesize}; 953 my $i = 1; 954 my $max; 955 while ($s--) { $max |= $i; $i <<= 1; } 956 957 my @tests = ( 958 # format, arg 959 ["%.${max}a", 1.1 ], 960 ["%.${max}i", 1 ], 961 ["%.${max}i", -1 ], 962 ); 963 964 for my $test (@tests) { 965 my ($fmt, $arg) = @$test; 966 eval { my $s = sprintf $fmt, $arg; }; 967 like("$@", qr/Integer overflow in format string/, 968 qq{Integer overflow: "$fmt", "$arg"}); 969 } 970} 971 972{ 973 # handle utf8 correctly when skipping invalid format 974 my $w_red = 0; 975 my $w_inv = 0; 976 my $w_other = 0; 977 local $SIG{__WARN__} = sub { 978 if ($_[0] =~ /^Invalid conversion/) { 979 $w_inv++; 980 } 981 elsif ($_[0] =~ /^Redundant argument/) { 982 $w_red++; 983 } 984 else { 985 $w_other++; 986 } 987 }; 988 989 use warnings; 990 my $cap_A_macron_utf8 = byte_utf8a_to_utf8n("\xc4\x80"); 991 my $small_a_breve_utf8 = byte_utf8a_to_utf8n("\xc4\x83"); 992 my $s = sprintf "%s%$cap_A_macron_utf8%s", 993 "\x{102}", 994 $small_a_breve_utf8; 995 is($s, "\x{102}%$cap_A_macron_utf8$small_a_breve_utf8", 996 "utf8 for invalid format"); 997 is($w_inv, 1, "utf8 for invalid format: invalid warnings"); 998 is($w_red, 0, "utf8 for invalid format: redundant warnings"); 999 is($w_other, 0, "utf8 for invalid format: other warnings"); 1000} 1001 1002# it used to upgrade the result to utf8 if the 1st arg happened to be utf8 1003 1004{ 1005 my $precis = "9"; 1006 utf8::upgrade($precis); 1007 my $s = sprintf "%.*f\n", $precis, 1.1; 1008 ok(!utf8::is_utf8($s), "first arg not special utf8-wise"); 1009} 1010 1011# sprintf("%n") used to croak "Modification of a read-only value" 1012# as it tried to set &PL_sv_no 1013 1014{ 1015 eval { my $s = sprintf("%n"); }; 1016 like $@, qr/Missing argument for %n in sprintf/, "%n"; 1017} 1018 1019# %p of an Inf or Nan address should still print its address, not 1020# 'Inf' etc. 1021 1022like sprintf("%p", 0+'Inf'), qr/^[0-9a-f]+$/, "%p and Inf"; 1023like sprintf("%p", 0+'NaN'), qr/^[0-9a-f]+$/, "%p and NaN"; 1024 1025# when the width or precision is specified by an argument, handle overflows 1026# ditto for literal precisions. 1027 1028{ 1029 for my $i ( 1030 (~0 ) - 0, # UV_MAX 1031 (~0 ) - 1, 1032 (~0 ) - 2, 1033 1034 (~0 >> 1) + 2, 1035 (~0 >> 1) + 1, 1036 (~0 >> 1) - 0, # IV_MAX 1037 (~0 >> 1) - 1, 1038 (~0 >> 1) - 2, 1039 1040 (~0 >> 2) + 2, 1041 (~0 >> 2) + 1, 1042 1043 -1 - (~0 >> 1),# -(IV_MAX+1) 1044 0 - (~0 >> 1), 1045 1 - (~0 >> 1), 1046 1047 -2 - (~0 >> 2), 1048 -1 - (~0 >> 2), 1049 ) 1050 { 1051 my $hex = sprintf "0x%x", $i; 1052 eval { my $s = sprintf '%*s', $i, "abc"; }; 1053 like $@, qr/Integer overflow/, "overflow: %*s $hex, $i"; 1054 1055 eval { my $s = sprintf '%*2$s', "abc", $i; }; 1056 like $@, qr/Integer overflow/, 'overflow: %*2$s'; 1057 1058 eval { my $s = sprintf '%.*s', $i, "abc"; }; 1059 like $@, qr/Integer overflow/, 'overflow: %.*s'; 1060 1061 eval { my $s = sprintf '%.*2$s', "abc", $i; }; 1062 like $@, qr/Integer overflow/, 'overflow: %.*2$s'; 1063 1064 next if $i < 0; 1065 1066 eval { my $s = sprintf "%.${i}f", 1.234 }; 1067 like $@, qr/Integer overflow/, 'overflow: %.NNNf'; 1068 } 1069} 1070 1071# multiconcat: only one scalar assign at most should be optimised away 1072 1073{ 1074 local our $x1 = ''; 1075 local our $x2 = ''; 1076 my ($a, $b) = qw(abcd wxyz); 1077 $x1 = ($x2 = sprintf("%s%s", $a, $b)); 1078 is $x1, "abcdwxyz", "\$x1 = \$x2 = sprintf(): x1"; 1079 is $x2, "abcdwxyz", "\$x1 = \$x2 = sprintf(): x2"; 1080 1081 my $y1 = ''; 1082 my $y2 = ''; 1083 $y1 = ($y2 = sprintf("%s%s", $a, $b)); 1084 is $y1, "abcdwxyz", "\$y1 = \$y2 = sprintf(): y1"; 1085 is $y2, "abcdwxyz", "\$y1 = \$y2 = sprintf(): y2"; 1086} 1087 1088# multiconcat: mutator optimisation 1089 1090{ 1091 my $lex = 'abc'; 1092 my $a1 = 'pqr'; 1093 my $a2 = 'xyz'; 1094 $lex .= sprintf "(%s,%s)", $a1, $a2; 1095 is $lex, "abc(pqr,xyz)", "\$lex .= sprintf ..."; 1096 1097 local our $pkg = "def"; 1098 $pkg .= sprintf "(%s,%s)", $a1, $a2; 1099 is $pkg, "def(pqr,xyz)", "\$pkg .= sprintf ..."; 1100 1101 my @ary; 1102 $ary[3] = "ghi"; 1103 $ary[3] .= sprintf "(%s,%s)", $a1, $a2; 1104 is $ary[3], "ghi(pqr,xyz)", "\$ary[3] .= sprintf ..."; 1105} 1106 1107# multiconcat: strings with 0x80..0xff chars and/or utf8 chars 1108 1109{ 1110 my $plain = "abc"; 1111 my $s80 = "d\x{80}e"; 1112 my $s81 = "h\x{81}i"; 1113 my $utf8 = "f\x{100}g"; 1114 my $res; 1115 1116 $res = sprintf "-%s-%s-\x{90}-%s-\x{91}-%s-\x{92}", 1117 $plain, $s80, $utf8, $s81; 1118 is $res, "-abc-d\x{80}e-\x{90}-f\x{100}g-\x{91}-h\x{81}i-\x{92}", 1119 "multiconcat 80.ff handling"; 1120 1121 $res = sprintf "%s \x{101} %s", $plain, $plain; 1122 is $res, "abc \x{101} abc", "multiconcat p u p"; 1123 1124 $res = sprintf "%s \x{101} %s", $plain, $utf8; 1125 is $res, "abc \x{101} f\x{100}g", "multiconcat p u u"; 1126} 1127 1128# check /INTRO flag set correctly on multiconcat 1129 1130{ 1131 my $a = "a"; 1132 my $b = "b"; 1133 my $x; 1134 { 1135 $x = sprintf "-%s-%s-", $a, $b; 1136 } 1137 is $x, "-a-b-", "no INTRO flag on non-my"; 1138 for (1,2) { 1139 my $y; 1140 is $y, undef, "INTRO flag on my: $_"; 1141 $y = sprintf "-%s-%s-", $b, $a; 1142 is $y, "-b-a-", "INTRO flag on my - result: $_"; 1143 } 1144} 1145 1146# variant chars in constant format (not utf8, but change if upgraded) 1147 1148{ 1149 my $x = "\x{100}"; 1150 my $y = sprintf "%sa\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80", $x; 1151 is $y, "\x{100}a\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80", 1152 "\\x80 in format"; 1153} 1154 1155foreach( 1156 0.0, -0.0, 1157 4503599627370501, -4503599627370501, 1158 4503599627370503, -4503599627370503, 1159) { 1160 is sprintf("%.0f", $_), sprintf("%-.0f", $_), "special-case %.0f on $_"; 1161} 1162 1163# large uvsize needed so the large width is parsed properly 1164# large sizesize needed so the STRLEN check doesn't 1165if ($Config{intsize} == 4 && $Config{uvsize} > 4 && $Config{sizesize} > 4) { 1166 eval { my $x = sprintf("%7000000000E", 0) }; 1167 like($@, qr/^Numeric format result too large at /, 1168 "croak for very large numeric format results"); 1169} 1170 1171{ 1172 # gh #17221 1173 my ($off1, $off2); 1174 my $x = eval { sprintf "%n0%n\x{100}", $off1, $off2 }; 1175 is($@, "", "no exception"); 1176 is($x, "0\x{100}", "reasonable result"); 1177 is($off1, 0, "offset at start"); 1178 is($off2, 1, "offset after 0"); 1179} 1180 1181# %g formatting was broken on Ubuntu, Debian and perhaps other systems 1182# for a long time. Here we verify that no such breakage still exists. 1183# See https://github.com/Perl/perl5/issues/18170 1184 1185if($Config{nvsize} == 8) { 1186 # double or 8-byte long double 1187 TODO: { 1188 local $::TODO = 'Extended precision %g formatting' if $^O eq 'cygwin' 1189 or 1190 $^O eq 'VMS' 1191 or 1192 ($^O eq 'MSWin32' and 1193 $Config{cc} eq 'cl' and 1194 $Config{ccversion} =~ /^(\d+)/ and 1195 $1 < 19); 1196 1197 cmp_ok(sprintf("%.54g", 0.3), 'eq', '0.299999999999999988897769753748434595763683319091796875', 1198 "sprintf( \"%.54g\", 0.3 ) renders correctly"); 1199 } 1200} 1201elsif($Config{nvtype} eq 'long double' && ($Config{longdblkind} == 3 || $Config{longdblkind} == 4)) { 1202 # 80-bit extended precision long double 1203 TODO: { 1204 local $::TODO = 'Extended precision %g formatting' if $^O eq 'cygwin'; 1205 1206 cmp_ok(sprintf("%.64g", 0.3), 'eq', '0.3000000000000000000108420217248550443400745280086994171142578125', 1207 "sprintf( \"%.64g\", 0.3 ) renders correctly"); 1208 } 1209} 1210elsif($Config{nvtype} eq 'long double' && $Config{longdblkind} >= 5 && $Config{longdblkind} <= 8) { 1211 # double-double 1212 cmp_ok(sprintf("%.108g", 0.1), 'eq', 1213 '0.0999999999999999999999999999999996918512088980422635110435291864116290339037362855378887616097927093505859375', 1214 "sprintf( \"%.108g\", 0.1 ) renders correctly"); 1215} 1216else { 1217 # IEEE-754 128-bit long double or __float128 1218 cmp_ok(sprintf("%.115g", 0.3), 'eq', 1219 '0.299999999999999999999999999999999990370350278063820734720110287075363407309491758923059023800306022167205810546875', 1220 "sprintf( \"%.115g\", 0.3 ) renders correctly"); 1221} 1222 1223done_testing(); 1224