| 1 | #!./perl -w |
| 2 | |
| 3 | # Tests for sprintf that do not fit the format of sprintf.t. |
| 4 | |
| 5 | BEGIN { |
| 6 | chdir 't' if -d 't'; |
| 7 | require './test.pl'; |
| 8 | set_up_inc('../lib'); |
| 9 | } |
| 10 | |
| 11 | # We'll run 12 extra tests (see below) if $Q is false. |
| 12 | eval { my $q = pack "q", 0 }; |
| 13 | my $Q = $@ eq ''; |
| 14 | |
| 15 | my $doubledouble; |
| 16 | |
| 17 | # %a and %A depend on the floating point config |
| 18 | # This totally doesn't test non-IEEE-754 float formats. |
| 19 | my @hexfloat; |
| 20 | print "# uvsize = $Config{uvsize}\n"; |
| 21 | print "# nvsize = $Config{nvsize}\n"; |
| 22 | print "# nv_preserves_uv_bits = $Config{nv_preserves_uv_bits}\n"; |
| 23 | print "# d_quad = $Config{d_quad}\n"; |
| 24 | print "# uselongdouble = " . ($Config{uselongdouble} // 'undef') . "\n"; |
| 25 | if ($Config{nvsize} == 8 && |
| 26 | ( |
| 27 | # IEEE-754 64-bit ("double precision"), the most common out there |
| 28 | ($Config{uvsize} == 8 && $Config{nv_preserves_uv_bits} == 53) |
| 29 | || |
| 30 | # If we have a quad we can still get the mantissa bits. |
| 31 | ($Config{uvsize} == 4 && $Config{d_quad}) |
| 32 | ) |
| 33 | ) { |
| 34 | @hexfloat = ( |
| 35 | [ '%a', '0', '0x0p+0' ], |
| 36 | [ '%a', '1', '0x1p+0' ], |
| 37 | [ '%a', '1.0', '0x1p+0' ], |
| 38 | [ '%a', '0.5', '0x1p-1' ], |
| 39 | [ '%a', '0.25', '0x1p-2' ], |
| 40 | [ '%a', '0.75', '0x1.8p-1' ], |
| 41 | [ '%a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 42 | [ '%a', '-1.0', '-0x1p+0' ], |
| 43 | [ '%a', '-3.14', '-0x1.91eb851eb851fp+1' ], |
| 44 | [ '%a', '0.1', '0x1.999999999999ap-4' ], |
| 45 | [ '%a', '1/7', '0x1.2492492492492p-3' ], |
| 46 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcdp+0' ], |
| 47 | [ '%a', 'exp(1)', '0x1.5bf0a8b145769p+1' ], |
| 48 | [ '%a', '2**-10', '0x1p-10' ], |
| 49 | [ '%a', '2**10', '0x1p+10' ], |
| 50 | [ '%a', '1e-9', '0x1.12e0be826d695p-30' ], |
| 51 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
| 52 | |
| 53 | [ '%#a', '1', '0x1.p+0' ], |
| 54 | [ '%+a', '1', '+0x1p+0' ], |
| 55 | [ '%+a', '-1', '-0x1p+0' ], |
| 56 | [ '% a', ' 1', ' 0x1p+0' ], |
| 57 | [ '% a', '-1', '-0x1p+0' ], |
| 58 | |
| 59 | [ '%+ a', '1', '+0x1p+0' ], |
| 60 | [ '%+ a', '-1', '-0x1p+0' ], |
| 61 | [ '% +a', ' 1', '+0x1p+0' ], |
| 62 | [ '% +a', '-1', '-0x1p+0' ], |
| 63 | |
| 64 | [ '%8a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 65 | [ '%13a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 66 | [ '%20a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 67 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
| 68 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], |
| 69 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], |
| 70 | [ '%.20a', '3.14', '0x1.91eb851eb851f0000000p+1' ], |
| 71 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 72 | [ '%20.15a', '3.14', '0x1.91eb851eb851f00p+1' ], |
| 73 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 74 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], |
| 75 | |
| 76 | [ '%.13a', '1', '0x1.0000000000000p+0' ], |
| 77 | [ '%.13a', '-1', '-0x1.0000000000000p+0' ], |
| 78 | [ '%.13a', '0', '0x0.0000000000000p+0' ], |
| 79 | |
| 80 | [ '%30a', '3.14', ' 0x1.91eb851eb851fp+1' ], |
| 81 | [ '%-30a', '3.14', '0x1.91eb851eb851fp+1 ' ], |
| 82 | [ '%030a', '3.14', '0x00000000001.91eb851eb851fp+1' ], |
| 83 | [ '%-030a', '3.14', '0x1.91eb851eb851fp+1 ' ], |
| 84 | |
| 85 | [ '%.40a', '3.14', |
| 86 | '0x1.91eb851eb851f000000000000000000000000000p+1' ], |
| 87 | |
| 88 | [ '%A', '3.14', '0X1.91EB851EB851FP+1' ], |
| 89 | ); |
| 90 | } elsif (($Config{nvsize} == 16 || $Config{nvsize} == 12) && |
| 91 | # 80-bit ("extended precision") long double, pack F is the NV |
| 92 | # cd cc cc cc cc cc cc cc fb bf 00 00 00 00 00 00 |
| 93 | # cd cc cc cc cc cc cc cc fb bf 00 00 |
| 94 | (pack("F", 0.1) =~ /^\xCD/ || # LE |
| 95 | pack("F", 0.1) =~ /\xCD$/)) { # BE (if this ever happens) |
| 96 | @hexfloat = ( |
| 97 | [ '%a', '0', '0x0p+0' ], |
| 98 | [ '%a', '1', '0x8p-3' ], |
| 99 | [ '%a', '1.0', '0x8p-3' ], |
| 100 | [ '%a', '0.5', '0x8p-4' ], |
| 101 | [ '%a', '0.25', '0x8p-5' ], |
| 102 | [ '%a', '0.75', '0xcp-4' ], |
| 103 | [ '%a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 104 | [ '%a', '-1.0', '-0x8p-3' ], |
| 105 | [ '%a', '-3.14', '-0xc.8f5c28f5c28f5c3p-2' ], |
| 106 | [ '%a', '0.1', '0xc.ccccccccccccccdp-7' ], |
| 107 | [ '%a', '1/7', '0x9.249249249249249p-6' ], |
| 108 | [ '%a', 'sqrt(2)', '0xb.504f333f9de6484p-3' ], |
| 109 | [ '%a', 'exp(1)', '0xa.df85458a2bb4a9bp-2' ], |
| 110 | [ '%a', '2**-10', '0x8p-13' ], |
| 111 | [ '%a', '2**10', '0x8p+7' ], |
| 112 | [ '%a', '1e-9', '0x8.9705f4136b4a597p-33' ], |
| 113 | [ '%a', '1e9', '0xe.e6b28p+26' ], |
| 114 | |
| 115 | [ '%#a', '1', '0x8.p-3' ], |
| 116 | [ '%+a', '1', '+0x8p-3' ], |
| 117 | [ '%+a', '-1', '-0x8p-3' ], |
| 118 | [ '% a', ' 1', ' 0x8p-3' ], |
| 119 | [ '% a', '-1', '-0x8p-3' ], |
| 120 | |
| 121 | [ '%+ a', '1', '+0x8p-3' ], |
| 122 | [ '%+ a', '-1', '-0x8p-3' ], |
| 123 | [ '% +a', ' 1', '+0x8p-3' ], |
| 124 | [ '% +a', '-1', '-0x8p-3' ], |
| 125 | |
| 126 | [ '%8a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 127 | [ '%13a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 128 | [ '%20a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 129 | [ '%.4a', '3.14', '0xc.8f5cp-2' ], |
| 130 | [ '%.5a', '3.14', '0xc.8f5c3p-2' ], |
| 131 | [ '%.6a', '3.14', '0xc.8f5c29p-2' ], |
| 132 | [ '%.20a', '3.14', '0xc.8f5c28f5c28f5c300000p-2' ], |
| 133 | [ '%20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], |
| 134 | [ '%20.15a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 135 | [ '% 20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], |
| 136 | [ '%020.10a', '3.14', '0x000c.8f5c28f5c3p-2' ], |
| 137 | |
| 138 | [ '%30a', '3.14', ' 0xc.8f5c28f5c28f5c3p-2' ], |
| 139 | [ '%-30a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], |
| 140 | [ '%030a', '3.14', '0x00000000c.8f5c28f5c28f5c3p-2' ], |
| 141 | [ '%-030a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], |
| 142 | |
| 143 | [ '%.40a', '3.14', |
| 144 | '0xc.8f5c28f5c28f5c30000000000000000000000000p-2' ], |
| 145 | |
| 146 | [ '%A', '3.14', '0XC.8F5C28F5C28F5C3P-2' ], |
| 147 | ); |
| 148 | } elsif ( |
| 149 | # IEEE 754 128-bit ("quadruple precision"), e.g. IA-64 (Itanium) in VMS |
| 150 | $Config{nvsize} == 16 && |
| 151 | # 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f (LE), pack F is the NV |
| 152 | (pack("F", 0.1) =~ /^\x9A\x99{6}/ || # LE |
| 153 | pack("F", 0.1) =~ /\x99{6}\x9A$/) # BE |
| 154 | ) { |
| 155 | @hexfloat = ( |
| 156 | [ '%a', '0', '0x0p+0' ], |
| 157 | [ '%a', '1', '0x1p+0' ], |
| 158 | [ '%a', '1.0', '0x1p+0' ], |
| 159 | [ '%a', '0.5', '0x1p-1' ], |
| 160 | [ '%a', '0.25', '0x1p-2' ], |
| 161 | [ '%a', '0.75', '0x1.8p-1' ], |
| 162 | [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 163 | [ '%a', '-1', '-0x1p+0' ], |
| 164 | [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 165 | [ '%a', '0.1', '0x1.999999999999999999999999999ap-4' ], |
| 166 | [ '%a', '1/7', '0x1.2492492492492492492492492492p-3' ], |
| 167 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea95p+0' ], |
| 168 | [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e7ap+1' ], |
| 169 | [ '%a', '2**-10', '0x1p-10' ], |
| 170 | [ '%a', '2**10', '0x1p+10' ], |
| 171 | [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f12ap-30' ], |
| 172 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
| 173 | |
| 174 | [ '%#a', '1', '0x1.p+0' ], |
| 175 | [ '%+a', '1', '+0x1p+0' ], |
| 176 | [ '%+a', '-1', '-0x1p+0' ], |
| 177 | [ '% a', '1', ' 0x1p+0' ], |
| 178 | [ '% a', '-1', '-0x1p+0' ], |
| 179 | |
| 180 | [ '%+ a', '1', '+0x1p+0' ], |
| 181 | [ '%+ a', '-1', '-0x1p+0' ], |
| 182 | [ '% +a', ' 1', '+0x1p+0' ], |
| 183 | [ '% +a', '-1', '-0x1p+0' ], |
| 184 | |
| 185 | [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 186 | [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 187 | [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 188 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
| 189 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], |
| 190 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], |
| 191 | [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], |
| 192 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 193 | [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], |
| 194 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 195 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], |
| 196 | |
| 197 | [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 198 | [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 199 | [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 200 | [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 201 | |
| 202 | [ '%.40a', '3.14', |
| 203 | '0x1.91eb851eb851eb851eb851eb851f000000000000p+1' ], |
| 204 | |
| 205 | [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB851FP+1' ], |
| 206 | ); |
| 207 | } elsif ( |
| 208 | # "double-double", two 64-bit doubles end to end |
| 209 | $Config{nvsize} == 16 && |
| 210 | # bf b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE), pack F is the NV |
| 211 | (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ || # LE |
| 212 | pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/) # BE |
| 213 | ) { |
| 214 | $doubledouble = 1; |
| 215 | @hexfloat = ( |
| 216 | [ '%a', '0', '0x0p+0' ], |
| 217 | [ '%a', '1', '0x1p+0' ], |
| 218 | [ '%a', '1.0', '0x1p+0' ], |
| 219 | [ '%a', '0.5', '0x1p-1' ], |
| 220 | [ '%a', '0.25', '0x1p-2' ], |
| 221 | [ '%a', '0.75', '0x1.8p-1' ], |
| 222 | [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 223 | [ '%a', '-1', '-0x1p+0' ], |
| 224 | [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 225 | [ '%a', '0.1', '0x1.999999999999999999999999998p-4' ], |
| 226 | [ '%a', '1/7', '0x1.249249249249249249249249248p-3' ], |
| 227 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea8p+0' ], |
| 228 | [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e8p+1' ], |
| 229 | [ '%a', '2**-10', '0x1p-10' ], |
| 230 | [ '%a', '2**10', '0x1p+10' ], |
| 231 | [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f14p-30' ], |
| 232 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
| 233 | |
| 234 | [ '%#a', '1', '0x1.p+0' ], |
| 235 | [ '%+a', '1', '+0x1p+0' ], |
| 236 | [ '%+a', '-1', '-0x1p+0' ], |
| 237 | [ '% a', '1', ' 0x1p+0' ], |
| 238 | [ '% a', '-1', '-0x1p+0' ], |
| 239 | |
| 240 | [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 241 | [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 242 | [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 243 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
| 244 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], |
| 245 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], |
| 246 | [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], |
| 247 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 248 | [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], |
| 249 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 250 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], |
| 251 | |
| 252 | [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 253 | [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 254 | [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 255 | [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 256 | |
| 257 | [ '%.40a', '3.14', |
| 258 | '0x1.91eb851eb851eb851eb851eb8500000000000000p+1' ], |
| 259 | |
| 260 | [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB85P+1' ], |
| 261 | ); |
| 262 | } else { |
| 263 | print "# no hexfloat tests\n"; |
| 264 | } |
| 265 | |
| 266 | use strict; |
| 267 | use Config; |
| 268 | |
| 269 | is( |
| 270 | sprintf("%.40g ",0.01), |
| 271 | sprintf("%.40g", 0.01)." ", |
| 272 | q(the sprintf "%.<number>g" optimization) |
| 273 | ); |
| 274 | is( |
| 275 | sprintf("%.40f ",0.01), |
| 276 | sprintf("%.40f", 0.01)." ", |
| 277 | q(the sprintf "%.<number>f" optimization) |
| 278 | ); |
| 279 | |
| 280 | # cases of $i > 1 are against [perl #39126] |
| 281 | for my $i (1, 5, 10, 20, 50, 100) { |
| 282 | chop(my $utf8_format = "%-*s\x{100}"); |
| 283 | my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT |
| 284 | my $expect = $string." "x$i; # followed by 2*$i spaces |
| 285 | is(sprintf($utf8_format, 3*$i, $string), $expect, |
| 286 | "width calculation under utf8 upgrade, length=$i"); |
| 287 | } |
| 288 | |
| 289 | # check simultaneous width & precision with wide characters |
| 290 | for my $i (1, 3, 5, 10) { |
| 291 | my $string = "\x{0410}"x($i+10); # cyrillic capital A |
| 292 | my $expect = "\x{0410}"x$i; # cut down to exactly $i characters |
| 293 | my $format = "%$i.${i}s"; |
| 294 | is(sprintf($format, $string), $expect, |
| 295 | "width & precision interplay with utf8 strings, length=$i"); |
| 296 | } |
| 297 | |
| 298 | # Used to mangle PL_sv_undef |
| 299 | fresh_perl_like( |
| 300 | 'print sprintf "xxx%n\n"; print undef', |
| 301 | qr/Modification of a read-only value attempted at\b/, |
| 302 | { switches => [ '-w' ] }, |
| 303 | q(%n should not be able to modify read-only constants), |
| 304 | ); |
| 305 | |
| 306 | # check overflows |
| 307 | for (int(~0/2+1), ~0, "9999999999999999999") { |
| 308 | is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d"); |
| 309 | like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf"); |
| 310 | is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d"); |
| 311 | like($@, qr/^Integer overflow in format string for printf /, "overflow in printf"); |
| 312 | } |
| 313 | |
| 314 | # check %NNN$ for range bounds |
| 315 | { |
| 316 | my ($warn, $bad) = (0,0); |
| 317 | local $SIG{__WARN__} = sub { |
| 318 | if ($_[0] =~ /missing argument/i) { |
| 319 | $warn++ |
| 320 | } |
| 321 | else { |
| 322 | $bad++ |
| 323 | } |
| 324 | }; |
| 325 | |
| 326 | my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); |
| 327 | my $result = sprintf $fmt, qw(a b c d); |
| 328 | is($result, "abcd", "only four valid values in $fmt"); |
| 329 | is($warn, 36, "expected warnings"); |
| 330 | is($bad, 0, "unexpected warnings"); |
| 331 | } |
| 332 | |
| 333 | # Tests for "missing argument" and "redundant argument" warnings |
| 334 | { |
| 335 | my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); |
| 336 | local $SIG{__WARN__} = sub { |
| 337 | if ($_[0] =~ /missing argument/i) { |
| 338 | $warn_missing++ |
| 339 | } |
| 340 | elsif ($_[0] =~ /redundant argument/i) { |
| 341 | $warn_redundant++ |
| 342 | } |
| 343 | else { |
| 344 | $warn_bad++ |
| 345 | } |
| 346 | }; |
| 347 | |
| 348 | my @tests = ( |
| 349 | # The "", "%s", and "%-p" formats have special-case handling |
| 350 | # in sv.c |
| 351 | { |
| 352 | fmt => "", |
| 353 | args => [ qw( x ) ], |
| 354 | res => "", |
| 355 | m => 0, |
| 356 | r => 1, |
| 357 | }, |
| 358 | { |
| 359 | fmt => "%s", |
| 360 | args => [ qw( x y ) ], |
| 361 | res => "x", |
| 362 | m => 0, |
| 363 | r => 1, |
| 364 | }, |
| 365 | { |
| 366 | fmt => "%-p", |
| 367 | args => [ qw( x y ) ], |
| 368 | res => qr/^[0-9a-f]+$/as, |
| 369 | m => 0, |
| 370 | r => 1, |
| 371 | }, |
| 372 | # Other non-specialcased patterns |
| 373 | { |
| 374 | fmt => "%s : %s", |
| 375 | args => [ qw( a b c ) ], |
| 376 | res => "a : b", |
| 377 | m => 0, |
| 378 | r => 1, |
| 379 | }, |
| 380 | { |
| 381 | fmt => "%s : %s : %s", |
| 382 | args => [ qw( a b c d e ) ], |
| 383 | res => "a : b : c", |
| 384 | m => 0, |
| 385 | # Note how we'll only warn about redundant arguments once, |
| 386 | # even though both "d" and "e" are redundant... |
| 387 | r => 1, |
| 388 | }, |
| 389 | { |
| 390 | fmt => "%s : %s : %s", |
| 391 | args => [ ], |
| 392 | res => " : : ", |
| 393 | # ...But when arguments are missing we'll warn about every |
| 394 | # missing argument. This difference between the two |
| 395 | # warnings is a feature. |
| 396 | m => 3, |
| 397 | r => 0, |
| 398 | }, |
| 399 | |
| 400 | # Tests for format parameter indexes. |
| 401 | # |
| 402 | # Deciding what to do about these is a bit tricky, and so is |
| 403 | # "correctly" warning about missing arguments on them. |
| 404 | # |
| 405 | # Should we warn if you supply 4 arguments but only use |
| 406 | # argument 1,3 & 4? Or only if you supply 5 arguments and your |
| 407 | # highest used argument is 4? |
| 408 | # |
| 409 | # For some uses of this printf feature (e.g. i18n systems) |
| 410 | # it's a always a logic error to not print out every provided |
| 411 | # argument, but for some other uses skipping some might be a |
| 412 | # feature (although you could argue that then printf should be |
| 413 | # called as e.g: |
| 414 | # |
| 415 | # printf q[%1$s %3$s], x(), undef, z(); |
| 416 | # |
| 417 | # Instead of: |
| 418 | # |
| 419 | # printf q[%1$s %3$s], x(), y(), z(); |
| 420 | # |
| 421 | # Since calling the (possibly expensive) y() function is |
| 422 | # completely redundant there. |
| 423 | # |
| 424 | # We deal with all these potential problems by not even |
| 425 | # trying. If the pattern contains any format parameter indexes |
| 426 | # whatsoever we'll never warn about redundant arguments. |
| 427 | { |
| 428 | fmt => '%1$s : %2$s', |
| 429 | args => [ qw( x y z ) ], |
| 430 | res => "x : y", |
| 431 | m => 0, |
| 432 | r => 0, |
| 433 | }, |
| 434 | { |
| 435 | fmt => '%2$s : %4$s : %5$s', |
| 436 | args => [ qw( a b c d )], |
| 437 | res => "b : d : ", |
| 438 | m => 1, |
| 439 | r => 0, |
| 440 | }, |
| 441 | { |
| 442 | fmt => '%s : %1$s : %s', |
| 443 | args => [ qw( x y z ) ], |
| 444 | res => "x : x : y", |
| 445 | m => 0, |
| 446 | r => 0, |
| 447 | }, |
| 448 | |
| 449 | ); |
| 450 | |
| 451 | for my $i (0..$#tests) { |
| 452 | my $test = $tests[$i]; |
| 453 | my $result = sprintf $test->{fmt}, @{$test->{args}}; |
| 454 | |
| 455 | my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'"; |
| 456 | if (ref $test->{res} eq 'Regexp') { |
| 457 | like($result, $test->{res}, "$prefix got the right result"); |
| 458 | } else { |
| 459 | is($result, $test->{res}, "$prefix got the right result"); |
| 460 | } |
| 461 | is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings"); |
| 462 | is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings"); |
| 463 | is($warn_bad, 0, "$prefix No unknown warnings"); |
| 464 | |
| 465 | ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); |
| 466 | } |
| 467 | } |
| 468 | |
| 469 | { |
| 470 | foreach my $ord (0 .. 255) { |
| 471 | my $bad = 0; |
| 472 | local $SIG{__WARN__} = sub { |
| 473 | if ($_[0] !~ /^Invalid conversion in sprintf/) { |
| 474 | warn $_[0]; |
| 475 | $bad++; |
| 476 | } |
| 477 | }; |
| 478 | my $r = eval {sprintf '%v' . chr $ord}; |
| 479 | is ($bad, 0, "pattern '%v' . chr $ord"); |
| 480 | } |
| 481 | } |
| 482 | |
| 483 | sub mysprintf_int_flags { |
| 484 | my ($fmt, $num) = @_; |
| 485 | die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/; |
| 486 | my $flag = $1; |
| 487 | my $width = $2; |
| 488 | my $sign = $num < 0 ? '-' : |
| 489 | $flag =~ /\+/ ? '+' : |
| 490 | $flag =~ /\ / ? ' ' : |
| 491 | ''; |
| 492 | my $abs = abs($num); |
| 493 | my $padlen = $width - length($sign.$abs); |
| 494 | return |
| 495 | $flag =~ /0/ && $flag !~ /-/ # do zero padding |
| 496 | ? $sign . '0' x $padlen . $abs |
| 497 | : $flag =~ /-/ # left or right |
| 498 | ? $sign . $abs . ' ' x $padlen |
| 499 | : ' ' x $padlen . $sign . $abs; |
| 500 | } |
| 501 | |
| 502 | # Whole tests for "%4d" with 2 to 4 flags; |
| 503 | # total counts: 3 * (4**2 + 4**3 + 4**4) == 1008 |
| 504 | |
| 505 | my @flags = ("-", "+", " ", "0"); |
| 506 | for my $num (0, -1, 1) { |
| 507 | for my $f1 (@flags) { |
| 508 | for my $f2 (@flags) { |
| 509 | for my $f3 ('', @flags) { # '' for doubled flags |
| 510 | my $flag = $f1.$f2.$f3; |
| 511 | my $width = 4; |
| 512 | my $fmt = '%'."${flag}${width}d"; |
| 513 | my $result = sprintf($fmt, $num); |
| 514 | my $expect = mysprintf_int_flags($fmt, $num); |
| 515 | is($result, $expect, qq/sprintf("$fmt",$num)/); |
| 516 | |
| 517 | next if $f3 eq ''; |
| 518 | |
| 519 | for my $f4 (@flags) { # quadrupled flags |
| 520 | my $flag = $f1.$f2.$f3.$f4; |
| 521 | my $fmt = '%'."${flag}${width}d"; |
| 522 | my $result = sprintf($fmt, $num); |
| 523 | my $expect = mysprintf_int_flags($fmt, $num); |
| 524 | is($result, $expect, qq/sprintf("$fmt",$num)/); |
| 525 | } |
| 526 | } |
| 527 | } |
| 528 | } |
| 529 | } |
| 530 | |
| 531 | my $vax_float = (pack("d", 1) =~ /^[\x80\x10]\x40/); |
| 532 | |
| 533 | SKIP: { |
| 534 | if ($vax_float) { skip "VAX float has no Inf or NaN", 3 } |
| 535 | # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] |
| 536 | foreach my $n ('2**1e100', '-2**1e100', '2**1e100/2**1e100') { # +Inf, -Inf, NaN |
| 537 | eval { my $f = sprintf("%f", eval $n); }; |
| 538 | is $@, "", "sprintf(\"%f\", $n)"; |
| 539 | } |
| 540 | } |
| 541 | |
| 542 | # test %ll formats with and without HAS_QUAD |
| 543 | my @tests = ( |
| 544 | [ '%lld' => [qw( 4294967296 -100000000000000 )] ], |
| 545 | [ '%lli' => [qw( 4294967296 -100000000000000 )] ], |
| 546 | [ '%llu' => [qw( 4294967296 100000000000000 )] ], |
| 547 | [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], |
| 548 | [ '%Li' => [qw( 4294967296 -100000000000000 )] ], |
| 549 | [ '%Lu' => [qw( 4294967296 100000000000000 )] ], |
| 550 | ); |
| 551 | |
| 552 | for my $t (@tests) { |
| 553 | my($fmt, $nums) = @$t; |
| 554 | for my $num (@$nums) { |
| 555 | my $w = ''; |
| 556 | local $SIG{__WARN__} = sub { $w .= shift }; |
| 557 | my $sprintf_got = sprintf($fmt, $num); |
| 558 | if ($Q) { |
| 559 | is($sprintf_got, $num, "quad: $fmt -> $num"); |
| 560 | is($w, '', "no warnings for: $fmt -> $num"); |
| 561 | } else { |
| 562 | is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt"); |
| 563 | like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt"); |
| 564 | like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt"); |
| 565 | } |
| 566 | } |
| 567 | } |
| 568 | |
| 569 | # Check unicode vs byte length |
| 570 | for my $width (1,2,3,4,5,6,7) { |
| 571 | for my $precis (1,2,3,4,5,6,7) { |
| 572 | my $v = "\x{20ac}\x{20ac}"; |
| 573 | my $format = "%" . $width . "." . $precis . "s"; |
| 574 | my $chars = ($precis > 2 ? 2 : $precis); |
| 575 | my $space = ($width < 2 ? 0 : $width - $chars); |
| 576 | fresh_perl_is( |
| 577 | 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', |
| 578 | "$space$chars", |
| 579 | {}, |
| 580 | q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), |
| 581 | ); |
| 582 | } |
| 583 | } |
| 584 | |
| 585 | # Overload count |
| 586 | package o { |
| 587 | use overload |
| 588 | '""', sub { ++our $count; $_[0][0]; }, |
| 589 | '0+', sub { ++our $numcount; $_[0][1]; } |
| 590 | } |
| 591 | my $o = bless ["\x{100}",42], o::; |
| 592 | () = sprintf "%1s", $o; |
| 593 | is $o::count, '1', 'sprinf %1s overload count'; |
| 594 | $o::count = 0; |
| 595 | () = sprintf "%.1s", $o; |
| 596 | is $o::count, '1', 'sprinf %.1s overload count'; |
| 597 | $o::count = 0; |
| 598 | () = sprintf "%d", $o; |
| 599 | is $o::count, 0, 'sprintf %d string overload count is 0'; |
| 600 | is $o::numcount, 1, 'sprintf %d number overload count is 1'; |
| 601 | |
| 602 | SKIP: { # hexfp |
| 603 | if ($vax_float) { skip "VAX float no hexfp", scalar @hexfloat } |
| 604 | |
| 605 | my $ppc_linux = $Config{archname} =~ /^(?:ppc|power(?:pc)?)(?:64)?-linux/; |
| 606 | my $irix_ld = $Config{archname} =~ /^IP\d+-irix-ld$/; |
| 607 | |
| 608 | for my $t (@hexfloat) { |
| 609 | my ($format, $arg, $expected) = @$t; |
| 610 | $arg = eval $arg; |
| 611 | my $result = sprintf($format, $arg); |
| 612 | my $ok = $result eq $expected; |
| 613 | # For certain platforms (all of which are currently double-double, |
| 614 | # but different implementations, GNU vs vendor, two different archs |
| 615 | # (ppc and mips), and two different libm interfaces) we have some |
| 616 | # bits-in-the-last-hexdigit differences. |
| 617 | # Patch them up as TODOs instead of deadly errors. |
| 618 | if ($doubledouble && $ppc_linux && $arg =~ /^2.71828/) { |
| 619 | # gets '0x1.5bf0a8b1457695355fb8ac404ecp+1' |
| 620 | # wants '0x1.5bf0a8b1457695355fb8ac404e8p+1' |
| 621 | local $::TODO = "$Config{archname} exp(1)"; |
| 622 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); |
| 623 | next; |
| 624 | } |
| 625 | if ($doubledouble && $irix_ld && $arg =~ /^1.41421/) { |
| 626 | # gets '0x1.6a09e667f3bcc908b2fb1366eacp+0' |
| 627 | # wants '0x1.6a09e667f3bcc908b2fb1366ea8p+0' |
| 628 | local $::TODO = "$Config{archname} sqrt(2)"; |
| 629 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); |
| 630 | next; |
| 631 | } |
| 632 | if (!$ok && $result =~ /\./ && $expected =~ /\./) { |
| 633 | # It seems that there can be difference in the last bits: |
| 634 | # [perl #122578] |
| 635 | # got "0x1.5bf0a8b14576ap+1" |
| 636 | # expected "0x1.5bf0a8b145769p+1" |
| 637 | # (Android on ARM) |
| 638 | # |
| 639 | # Exact cause unknown but suspecting different fp rounding modes, |
| 640 | # (towards zero? towards +inf? towards -inf?) about which Perl |
| 641 | # is blissfully unaware. |
| 642 | # |
| 643 | # Try extracting one (or sometimes two) last mantissa |
| 644 | # hexdigits, and see if they differ in value by one. |
| 645 | my ($rh, $eh) = ($result, $expected); |
| 646 | sub extract_prefix { |
| 647 | ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1; |
| 648 | } |
| 649 | my $rp = extract_prefix($rh); |
| 650 | my $ep = extract_prefix($eh); |
| 651 | print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n"; |
| 652 | if ($rp eq $ep) { # If prefixes match. |
| 653 | sub extract_exponent { |
| 654 | ($_[0] =~ s/([pP][+-]?\d+)//) && return $1; |
| 655 | } |
| 656 | my $re = extract_exponent($rh); |
| 657 | my $ee = extract_exponent($eh); |
| 658 | print "# re = $re, ee = $ee (rh $rh, eh $eh)\n"; |
| 659 | if ($re eq $ee) { # If exponents match. |
| 660 | # Remove the common prefix of the mantissa bits. |
| 661 | my $la = length($rh); |
| 662 | my $lb = length($eh); |
| 663 | my $i; |
| 664 | for ($i = 0; $i < $la && $i < $lb; $i++) { |
| 665 | last if substr($rh, $i, 1) ne substr($eh, $i, 1); |
| 666 | } |
| 667 | $rh = substr($rh, $i); |
| 668 | $eh = substr($eh, $i); |
| 669 | print "# (rh $rh, eh $eh)\n"; |
| 670 | if ($rh ne $eh) { |
| 671 | # If necessary, pad the shorter one on the right |
| 672 | # with one zero (for example "...1f" vs "...2", |
| 673 | # we want to compare "1f" to "20"). |
| 674 | if (length $rh < length $eh) { |
| 675 | $rh .= '0'; |
| 676 | } elsif (length $eh < length $rh) { |
| 677 | $eh .= '0'; |
| 678 | } |
| 679 | print "# (rh $rh, eh $eh)\n"; |
| 680 | if (length $eh == length $rh) { |
| 681 | if (abs(hex($eh) - hex($rh)) == 1) { |
| 682 | $ok = 1; |
| 683 | } |
| 684 | } |
| 685 | } |
| 686 | } |
| 687 | } |
| 688 | } |
| 689 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); |
| 690 | } |
| 691 | |
| 692 | } # SKIP: # hexfp |
| 693 | |
| 694 | # double-double long double %a special testing. |
| 695 | SKIP: { |
| 696 | skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef') |
| 697 | . " longdblkind=$Config{longdblkind} os=$^O", 6) |
| 698 | unless ($Config{uselongdouble} && |
| 699 | ($Config{longdblkind} == 5 || |
| 700 | $Config{longdblkind} == 6) |
| 701 | # Gating on 'linux' (ppc) here is due to the differing |
| 702 | # double-double implementations: other (also big-endian) |
| 703 | # double-double platforms (e.g. AIX on ppc or IRIX on mips) |
| 704 | # do not behave similarly. |
| 705 | && $^O eq 'linux' |
| 706 | ); |
| 707 | # [rt.perl.org 125633] |
| 708 | like(sprintf("%La\n", eval '(2**1020) + (2**-1072)'), |
| 709 | qr/^0x1.0{522}1p\+1020$/); |
| 710 | like(sprintf("%La\n", eval '(2**1021) + (2**-1072)'), |
| 711 | qr/^0x1.0{523}8p\+1021$/); |
| 712 | like(sprintf("%La\n", eval '(2**1022) + (2**-1072)'), |
| 713 | qr/^0x1.0{523}4p\+1022$/); |
| 714 | like(sprintf("%La\n", eval '(2**1023) + (2**-1072)'), |
| 715 | qr/^0x1.0{523}2p\+1023$/); |
| 716 | like(sprintf("%La\n", eval '(2**1023) + (2**-1073)'), |
| 717 | qr/^0x1.0{523}1p\+1023$/); |
| 718 | like(sprintf("%La\n", eval '(2**1023) + (2**-1074)'), |
| 719 | qr/^0x1.0{524}8p\+1023$/); |
| 720 | } |
| 721 | |
| 722 | SKIP: { |
| 723 | skip("negative zero not available\n", 3) |
| 724 | unless sprintf('%+f', -0.0) =~ /^-0/; |
| 725 | is(sprintf("%a", -0.0), "-0x0p+0", "negative zero"); |
| 726 | is(sprintf("%+a", -0.0), "-0x0p+0", "negative zero"); |
| 727 | is(sprintf("%.13a", -0.0), "-0x0.0000000000000p+0", "negative zero"); |
| 728 | } |
| 729 | |
| 730 | SKIP: { |
| 731 | # [perl #127183] Non-canonical hexadecimal floats are parsed prematurely |
| 732 | |
| 733 | # IEEE 754 64-bit |
| 734 | skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53", 3) |
| 735 | unless $Config{nv_preserves_uv_bits} == 53; |
| 736 | |
| 737 | { |
| 738 | # The 0x0.b17217f7d1cf78p0 is the original LHS value |
| 739 | # from [perl #127183], its bits are 0x162e42fefa39ef << 3, |
| 740 | # resulting in a non-canonical form of hexfp, where the most |
| 741 | # significant bit is zero, instead of one. |
| 742 | is(sprintf("%a", 0x0.b17217f7d1cf78p0 - 0x1.62e42fefa39efp-1), |
| 743 | "0x0p+0", |
| 744 | "non-canonical form [perl #127183]"); |
| 745 | } |
| 746 | |
| 747 | { |
| 748 | no warnings 'overflow'; # Not the point here. |
| 749 | |
| 750 | # The 0x058b90bfbe8e7bc is 0x162e42fefa39ef << 2, |
| 751 | # the 0x02c5c85fdf473de is 0x162e42fefa39ef << 1, |
| 752 | # see above. |
| 753 | is(sprintf("%a", 0x0.58b90bfbe8e7bcp1 - 0x1.62e42fefa39efp-1), |
| 754 | "0x0p+0", |
| 755 | "non-canonical form"); |
| 756 | |
| 757 | is(sprintf("%a", 0x0.2c5c85fdf473dep2 - 0x1.62e42fefa39efp-1), |
| 758 | "0x0p+0", |
| 759 | "non-canonical form"); |
| 760 | } |
| 761 | } |
| 762 | |
| 763 | # These are IEEE 754 64-bit subnormals (formerly known as denormals). |
| 764 | # Keep these as strings so that non-IEEE-754 don't trip over them. |
| 765 | my @subnormals = ( |
| 766 | [ '1e-320', '%a', '0x1.fap-1064' ], |
| 767 | [ '1e-321', '%a', '0x1.94p-1067' ], |
| 768 | [ '1e-322', '%a', '0x1.4p-1070' ], |
| 769 | [ '1e-323', '%a', '0x1p-1073' ], |
| 770 | [ '1e-324', '%a', '0x0p+0' ], # underflow |
| 771 | [ '3e-320', '%a', '0x1.7b8p-1062' ], |
| 772 | [ '3e-321', '%a', '0x1.2f8p-1065' ], |
| 773 | [ '3e-322', '%a', '0x1.e8p-1069' ], |
| 774 | [ '3e-323', '%a', '0x1.8p-1072' ], |
| 775 | [ '3e-324', '%a', '0x1p-1074' ], # the smallest possible value |
| 776 | [ '7e-320', '%a', '0x1.bacp-1061' ], |
| 777 | [ '7e-321', '%a', '0x1.624p-1064' ], |
| 778 | [ '7e-322', '%a', '0x1.1cp-1067' ], |
| 779 | [ '7e-323', '%a', '0x1.cp-1071' ], |
| 780 | [ '7e-324', '%a', '0x1p-1074' ], # the smallest possible value, again |
| 781 | [ '3e-320', '%.4a', '0x1.7b80p-1062' ], |
| 782 | [ '3e-321', '%.4a', '0x1.2f80p-1065' ], |
| 783 | [ '3e-322', '%.4a', '0x1.e800p-1069' ], |
| 784 | [ '3e-323', '%.4a', '0x1.8000p-1072' ], |
| 785 | [ '3e-324', '%.4a', '0x1.0000p-1074' ], |
| 786 | [ '3e-320', '%.1a', '0x1.8p-1062' ], |
| 787 | [ '3e-321', '%.1a', '0x1.3p-1065' ], |
| 788 | [ '3e-322', '%.1a', '0x1.ep-1069' ], |
| 789 | [ '3e-323', '%.1a', '0x1.8p-1072' ], |
| 790 | [ '3e-324', '%.1a', '0x1.0p-1074' ], |
| 791 | [ '0x1.fffffffffffffp-1022', '%a', '0x1.fffffffffffffp-1022' ], |
| 792 | [ '0x0.fffffffffffffp-1022', '%a', '0x1.ffffffffffffep-1023' ], |
| 793 | [ '0x0.7ffffffffffffp-1022', '%a', '0x1.ffffffffffffcp-1024' ], |
| 794 | [ '0x0.3ffffffffffffp-1022', '%a', '0x1.ffffffffffff8p-1025' ], |
| 795 | [ '0x0.1ffffffffffffp-1022', '%a', '0x1.ffffffffffffp-1026' ], |
| 796 | [ '0x0.0ffffffffffffp-1022', '%a', '0x1.fffffffffffep-1027' ], |
| 797 | ); |
| 798 | |
| 799 | SKIP: { |
| 800 | # [rt.perl.org #128843] |
| 801 | skip("non-IEEE-754-non-64-bit", scalar @subnormals + 34) |
| 802 | unless ($Config{nvsize} == 8 && |
| 803 | $Config{nv_preserves_uv_bits} == 53 && |
| 804 | ($Config{doublekind} == 3 || |
| 805 | $Config{doublekind} == 4)); |
| 806 | |
| 807 | for my $t (@subnormals) { |
| 808 | # Note that "0x1p+2" is not considered numeric, |
| 809 | # since neither is "0x12", hence the eval. |
| 810 | my $s = sprintf($t->[1], eval $t->[0]); |
| 811 | is($s, $t->[2], "subnormal @$t got $s"); |
| 812 | } |
| 813 | |
| 814 | # [rt.perl.org #128888] |
| 815 | is(sprintf("%a", 1.03125), "0x1.08p+0"); |
| 816 | is(sprintf("%.1a", 1.03125), "0x1.0p+0"); |
| 817 | is(sprintf("%.0a", 1.03125), "0x1p+0", "[rt.perl.org #128888]"); |
| 818 | |
| 819 | # [rt.perl.org #128889] |
| 820 | is(sprintf("%.*a", -1, 1.03125), "0x1.08p+0", "[rt.perl.org #128889]"); |
| 821 | |
| 822 | # [rt.perl.org #128890] |
| 823 | is(sprintf("%a", 0x1.18p+0), "0x1.18p+0"); |
| 824 | is(sprintf("%.1a", 0x1.08p+0), "0x1.0p+0"); |
| 825 | is(sprintf("%.1a", 0x1.18p+0), "0x1.2p+0", "[rt.perl.org #128890]"); |
| 826 | is(sprintf("%.1a", 0x1.28p+0), "0x1.2p+0"); |
| 827 | is(sprintf("%.1a", 0x1.38p+0), "0x1.4p+0"); |
| 828 | is(sprintf("%.1a", 0x1.48p+0), "0x1.4p+0"); |
| 829 | is(sprintf("%.1a", 0x1.58p+0), "0x1.6p+0"); |
| 830 | is(sprintf("%.1a", 0x1.68p+0), "0x1.6p+0"); |
| 831 | is(sprintf("%.1a", 0x1.78p+0), "0x1.8p+0"); |
| 832 | is(sprintf("%.1a", 0x1.88p+0), "0x1.8p+0"); |
| 833 | is(sprintf("%.1a", 0x1.98p+0), "0x1.ap+0"); |
| 834 | is(sprintf("%.1a", 0x1.a8p+0), "0x1.ap+0"); |
| 835 | is(sprintf("%.1a", 0x1.b8p+0), "0x1.cp+0"); |
| 836 | is(sprintf("%.1a", 0x1.c8p+0), "0x1.cp+0"); |
| 837 | is(sprintf("%.1a", 0x1.d8p+0), "0x1.ep+0"); |
| 838 | is(sprintf("%.1a", 0x1.e8p+0), "0x1.ep+0"); |
| 839 | is(sprintf("%.1a", 0x1.f8p+0), "0x2.0p+0"); |
| 840 | |
| 841 | is(sprintf("%.1a", 0x1.10p+0), "0x1.1p+0"); |
| 842 | is(sprintf("%.1a", 0x1.17p+0), "0x1.1p+0"); |
| 843 | is(sprintf("%.1a", 0x1.19p+0), "0x1.2p+0"); |
| 844 | is(sprintf("%.1a", 0x1.1fp+0), "0x1.2p+0"); |
| 845 | |
| 846 | is(sprintf("%.2a", 0x1.fffp+0), "0x2.00p+0"); |
| 847 | is(sprintf("%.2a", 0xf.fffp+0), "0x2.00p+3"); |
| 848 | |
| 849 | # [rt.perl.org #128893] |
| 850 | is(sprintf("%020a", 1.5), "0x0000000000001.8p+0"); |
| 851 | is(sprintf("%020a", -1.5), "-0x000000000001.8p+0", "[rt.perl.org #128893]"); |
| 852 | is(sprintf("%+020a", 1.5), "+0x000000000001.8p+0", "[rt.perl.org #128893]"); |
| 853 | is(sprintf("% 020a", 1.5), " 0x000000000001.8p+0", "[rt.perl.org #128893]"); |
| 854 | is(sprintf("%20a", -1.5), " -0x1.8p+0"); |
| 855 | is(sprintf("%+20a", 1.5), " +0x1.8p+0"); |
| 856 | is(sprintf("% 20a", 1.5), " 0x1.8p+0"); |
| 857 | } |
| 858 | |
| 859 | # x86 80-bit long-double tests for |
| 860 | # rt.perl.org #128843, #128888, #128889, #128890, #128893, #128909 |
| 861 | SKIP: { |
| 862 | skip("non-80-bit-long-double", 17) |
| 863 | unless ($Config{uselongdouble} && |
| 864 | ($Config{nvsize} == 16 || $Config{nvsize} == 12) && |
| 865 | ($Config{longdblkind} == 3 || |
| 866 | $Config{longdblkind} == 4)); |
| 867 | |
| 868 | { |
| 869 | # The last normal for this format. |
| 870 | is(sprintf("%a", eval '0x1p-16382'), "0x8p-16385", "[rt.perl.org #128843]"); |
| 871 | |
| 872 | # The subnormals cause "exponent underflow" warnings, |
| 873 | # but that is not why we are here. |
| 874 | local $SIG{__WARN__} = sub { |
| 875 | die "$0: $_[0]" unless $_[0] =~ /exponent underflow/; |
| 876 | }; |
| 877 | |
| 878 | is(sprintf("%a", eval '0x1p-16383'), "0x4p-16382", "[rt.perl.org #128843]"); |
| 879 | is(sprintf("%a", eval '0x1p-16384'), "0x2p-16382", "[rt.perl.org #128843]"); |
| 880 | is(sprintf("%a", eval '0x1p-16385'), "0x1p-16382", "[rt.perl.org #128843]"); |
| 881 | is(sprintf("%a", eval '0x1p-16386'), "0x8p-16386", "[rt.perl.org #128843]"); |
| 882 | is(sprintf("%a", eval '0x1p-16387'), "0x4p-16386", "[rt.perl.org #128843]"); |
| 883 | } |
| 884 | is(sprintf("%.0a", 1.03125), "0x8p-3", "[rt.perl.org #128888]"); |
| 885 | is(sprintf("%.*a", -1, 1.03125), "0x8.4p-3", "[rt.perl.org #128889]"); |
| 886 | is(sprintf("%.1a", 0x8.18p+0), "0x8.2p+0", "[rt.perl.org #128890]"); |
| 887 | is(sprintf("%020a", -1.5), "-0x0000000000000cp-3", "[rt.perl.org #128893]"); |
| 888 | is(sprintf("%+020a", 1.5), "+0x0000000000000cp-3", "[rt.perl.org #128893]"); |
| 889 | is(sprintf("% 020a", 1.5), " 0x0000000000000cp-3", "[rt.perl.org #128893]"); |
| 890 | is(sprintf("%a", 1.9999999999999999999), "0xf.fffffffffffffffp-3"); |
| 891 | is(sprintf("%.3a", 1.9999999999999999999), "0x1.000p+1", "[rt.perl.org #128909]"); |
| 892 | is(sprintf("%.2a", 1.9999999999999999999), "0x1.00p+1"); |
| 893 | is(sprintf("%.1a", 1.9999999999999999999), "0x1.0p+1"); |
| 894 | is(sprintf("%.0a", 1.9999999999999999999), "0x1p+1"); |
| 895 | } |
| 896 | |
| 897 | # quadmath tests for rt.perl.org #128843 |
| 898 | SKIP: { |
| 899 | skip "need quadmath", 7, unless $Config{usequadmath}; |
| 900 | |
| 901 | is(sprintf("%a", eval '0x1p-16382'), '0x1p-16382'); # last normal |
| 902 | |
| 903 | local $SIG{__WARN__} = sub { |
| 904 | die "$0: $_[0]" unless $_[0] =~ /exponent underflow/; |
| 905 | }; |
| 906 | |
| 907 | is(sprintf("%a", eval '0x1p-16383'), '0x1p-16383'); |
| 908 | is(sprintf("%a", eval '0x1p-16384'), '0x1p-16384'); |
| 909 | |
| 910 | is(sprintf("%a", eval '0x1p-16491'), '0x1p-16491'); |
| 911 | is(sprintf("%a", eval '0x1p-16492'), '0x1p-16492'); |
| 912 | is(sprintf("%a", eval '0x1p-16493'), '0x1p-16493'); # last denormal |
| 913 | |
| 914 | is(sprintf("%a", eval '0x1p-16494'), '0x1p-16494'); # underflow |
| 915 | } |
| 916 | |
| 917 | done_testing(); |