| 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 | @INC = '../lib'; |
| 8 | require './test.pl'; |
| 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 | # %a and %A depend on the floating point config |
| 16 | # This totally doesn't test non-IEEE-754 float formats. |
| 17 | my @hexfloat; |
| 18 | print "# uvsize = $Config{uvsize}\n"; |
| 19 | print "# nvsize = $Config{nvsize}\n"; |
| 20 | print "# nv_preserves_uv_bits = $Config{nv_preserves_uv_bits}\n"; |
| 21 | print "# d_quad = $Config{d_quad}\n"; |
| 22 | if ($Config{nvsize} == 8 && |
| 23 | ( |
| 24 | # IEEE-754 64-bit ("double precision"), the most common out there |
| 25 | ($Config{uvsize} == 8 && $Config{nv_preserves_uv_bits} == 53) |
| 26 | || |
| 27 | # If we have a quad we can still get the mantissa bits. |
| 28 | ($Config{uvsize} == 4 && $Config{d_quad}) |
| 29 | ) |
| 30 | ) { |
| 31 | @hexfloat = ( |
| 32 | [ '%a', '0', '0x0p+0' ], |
| 33 | [ '%a', '1', '0x1p+0' ], |
| 34 | [ '%a', '1.0', '0x1p+0' ], |
| 35 | [ '%a', '0.5', '0x1p-1' ], |
| 36 | [ '%a', '0.25', '0x1p-2' ], |
| 37 | [ '%a', '0.75', '0x1.8p-1' ], |
| 38 | [ '%a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 39 | [ '%a', '-1.0', '-0x1p+0' ], |
| 40 | [ '%a', '-3.14', '-0x1.91eb851eb851fp+1' ], |
| 41 | [ '%a', '0.1', '0x1.999999999999ap-4' ], |
| 42 | [ '%a', '1/7', '0x1.2492492492492p-3' ], |
| 43 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcdp+0' ], |
| 44 | [ '%a', 'exp(1)', '0x1.5bf0a8b145769p+1' ], |
| 45 | [ '%a', '2**-10', '0x1p-10' ], |
| 46 | [ '%a', '2**10', '0x1p+10' ], |
| 47 | [ '%a', '1e-9', '0x1.12e0be826d695p-30' ], |
| 48 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
| 49 | |
| 50 | [ '%#a', '1', '0x1.p+0' ], |
| 51 | [ '%+a', '1', '+0x1p+0' ], |
| 52 | [ '%+a', '-1', '-0x1p+0' ], |
| 53 | [ '% a', ' 1', ' 0x1p+0' ], |
| 54 | [ '% a', '-1', '-0x1p+0' ], |
| 55 | |
| 56 | [ '%8a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 57 | [ '%13a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 58 | [ '%20a', '3.14', '0x1.91eb851eb851fp+1' ], |
| 59 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
| 60 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], |
| 61 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], |
| 62 | [ '%.20a', '3.14', '0x1.91eb851eb851f0000000p+1' ], |
| 63 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 64 | [ '%20.15a', '3.14', '0x1.91eb851eb851f00p+1' ], |
| 65 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 66 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], |
| 67 | |
| 68 | [ '%30a', '3.14', ' 0x1.91eb851eb851fp+1' ], |
| 69 | [ '%-30a', '3.14', '0x1.91eb851eb851fp+1 ' ], |
| 70 | [ '%030a', '3.14', '0x00000000001.91eb851eb851fp+1' ], |
| 71 | [ '%-030a', '3.14', '0x1.91eb851eb851fp+1 ' ], |
| 72 | |
| 73 | [ '%.40a', '3.14', |
| 74 | '0x1.91eb851eb851f000000000000000000000000000p+1' ], |
| 75 | |
| 76 | [ '%A', '3.14', '0X1.91EB851EB851FP+1' ], |
| 77 | ); |
| 78 | } elsif (($Config{nvsize} == 16 || $Config{nvsize} == 12) && |
| 79 | # 80-bit ("extended precision") long double, pack F is the NV |
| 80 | # cd cc cc cc cc cc cc cc fb bf 00 00 00 00 00 00 |
| 81 | # cd cc cc cc cc cc cc cc fb bf 00 00 |
| 82 | (pack("F", 0.1) =~ /^\xCD/ || # LE |
| 83 | pack("F", 0.1) =~ /\xCD$/)) { # BE (if this ever happens) |
| 84 | @hexfloat = ( |
| 85 | [ '%a', '0', '0x0p+0' ], |
| 86 | [ '%a', '1', '0x8p-3' ], |
| 87 | [ '%a', '1.0', '0x8p-3' ], |
| 88 | [ '%a', '0.5', '0x8p-4' ], |
| 89 | [ '%a', '0.25', '0x8p-5' ], |
| 90 | [ '%a', '0.75', '0xcp-4' ], |
| 91 | [ '%a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 92 | [ '%a', '-1.0', '-0x8p-3' ], |
| 93 | [ '%a', '-3.14', '-0xc.8f5c28f5c28f5c3p-2' ], |
| 94 | [ '%a', '0.1', '0xc.ccccccccccccccdp-7' ], |
| 95 | [ '%a', '1/7', '0x9.249249249249249p-6' ], |
| 96 | [ '%a', 'sqrt(2)', '0xb.504f333f9de6484p-3' ], |
| 97 | [ '%a', 'exp(1)', '0xa.df85458a2bb4a9bp-2' ], |
| 98 | [ '%a', '2**-10', '0x8p-13' ], |
| 99 | [ '%a', '2**10', '0x8p+7' ], |
| 100 | [ '%a', '1e-9', '0x8.9705f4136b4a597p-33' ], |
| 101 | [ '%a', '1e9', '0xe.e6b28p+26' ], |
| 102 | |
| 103 | [ '%#a', '1', '0x8.p-3' ], |
| 104 | [ '%+a', '1', '+0x8p-3' ], |
| 105 | [ '%+a', '-1', '-0x8p-3' ], |
| 106 | [ '% a', ' 1', ' 0x8p-3' ], |
| 107 | [ '% a', '-1', '-0x8p-3' ], |
| 108 | |
| 109 | [ '%8a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 110 | [ '%13a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 111 | [ '%20a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 112 | [ '%.4a', '3.14', '0xc.8f5cp-2' ], |
| 113 | [ '%.5a', '3.14', '0xc.8f5c3p-2' ], |
| 114 | [ '%.6a', '3.14', '0xc.8f5c29p-2' ], |
| 115 | [ '%.20a', '3.14', '0xc.8f5c28f5c28f5c300000p-2' ], |
| 116 | [ '%20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], |
| 117 | [ '%20.15a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], |
| 118 | [ '% 20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], |
| 119 | [ '%020.10a', '3.14', '0x000c.8f5c28f5c3p-2' ], |
| 120 | |
| 121 | [ '%30a', '3.14', ' 0xc.8f5c28f5c28f5c3p-2' ], |
| 122 | [ '%-30a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], |
| 123 | [ '%030a', '3.14', '0x00000000c.8f5c28f5c28f5c3p-2' ], |
| 124 | [ '%-030a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], |
| 125 | |
| 126 | [ '%.40a', '3.14', |
| 127 | '0xc.8f5c28f5c28f5c30000000000000000000000000p-2' ], |
| 128 | |
| 129 | [ '%A', '3.14', '0XC.8F5C28F5C28F5C3P-2' ], |
| 130 | ); |
| 131 | } elsif ( |
| 132 | # IEEE 754 128-bit ("quadruple precision"), e.g. IA-64 (Itanium) in VMS |
| 133 | $Config{nvsize} == 16 && |
| 134 | # 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f (LE), pack F is the NV |
| 135 | (pack("F", 0.1) =~ /^\x9A\x99{6}/ || # LE |
| 136 | pack("F", 0.1) =~ /\x99{6}\x9A$/) # BE |
| 137 | ) { |
| 138 | @hexfloat = ( |
| 139 | [ '%a', '0', '0x0p+0' ], |
| 140 | [ '%a', '1', '0x1p+0' ], |
| 141 | [ '%a', '1.0', '0x1p+0' ], |
| 142 | [ '%a', '0.5', '0x1p-1' ], |
| 143 | [ '%a', '0.25', '0x1p-2' ], |
| 144 | [ '%a', '0.75', '0x1.8p-1' ], |
| 145 | [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 146 | [ '%a', '-1', '-0x1p+0' ], |
| 147 | [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 148 | [ '%a', '0.1', '0x1.999999999999999999999999999ap-4' ], |
| 149 | [ '%a', '1/7', '0x1.2492492492492492492492492492p-3' ], |
| 150 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea95p+0' ], |
| 151 | [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e7ap+1' ], |
| 152 | [ '%a', '2**-10', '0x1p-10' ], |
| 153 | [ '%a', '2**10', '0x1p+10' ], |
| 154 | [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f12ap-30' ], |
| 155 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
| 156 | |
| 157 | [ '%#a', '1', '0x1.p+0' ], |
| 158 | [ '%+a', '1', '+0x1p+0' ], |
| 159 | [ '%+a', '-1', '-0x1p+0' ], |
| 160 | [ '% a', '1', ' 0x1p+0' ], |
| 161 | [ '% a', '-1', '-0x1p+0' ], |
| 162 | |
| 163 | [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 164 | [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 165 | [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 166 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
| 167 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], |
| 168 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], |
| 169 | [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], |
| 170 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 171 | [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], |
| 172 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 173 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], |
| 174 | |
| 175 | [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 176 | [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 177 | [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 178 | [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], |
| 179 | |
| 180 | [ '%.40a', '3.14', |
| 181 | '0x1.91eb851eb851eb851eb851eb851f000000000000p+1' ], |
| 182 | |
| 183 | [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB851FP+1' ], |
| 184 | ); |
| 185 | } elsif ( |
| 186 | # "double-double", two 64-bit doubles end to end |
| 187 | $Config{nvsize} == 16 && |
| 188 | # bf b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE), pack F is the NV |
| 189 | (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ || # LE |
| 190 | pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/) # BE |
| 191 | ) { |
| 192 | @hexfloat = ( |
| 193 | [ '%a', '0', '0x0p+0' ], |
| 194 | [ '%a', '1', '0x1p+0' ], |
| 195 | [ '%a', '1.0', '0x1p+0' ], |
| 196 | [ '%a', '0.5', '0x1p-1' ], |
| 197 | [ '%a', '0.25', '0x1p-2' ], |
| 198 | [ '%a', '0.75', '0x1.8p-1' ], |
| 199 | [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 200 | [ '%a', '-1', '-0x0p+0' ], |
| 201 | [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 202 | [ '%a', '0.1', '0x1.999999999999999999999999998p-4' ], |
| 203 | [ '%a', '1/7', '0x1.249249249249249249249249248p-3' ], |
| 204 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea8p+0' ], |
| 205 | [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e8p+1' ], |
| 206 | [ '%a', '2**-10', '0x1p-10' ], |
| 207 | [ '%a', '2**10', '0x1p+10' ], |
| 208 | [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f14p-30' ], |
| 209 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
| 210 | |
| 211 | [ '%#a', '1', '0x1.p+0' ], |
| 212 | [ '%+a', '1', '+0x1p+0' ], |
| 213 | [ '%+a', '-1', '-0x1p+0' ], |
| 214 | [ '% a', '1', ' 0x1p+0' ], |
| 215 | [ '% a', '-1', '-0x1p+0' ], |
| 216 | |
| 217 | [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 218 | [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 219 | [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 220 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
| 221 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], |
| 222 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], |
| 223 | [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], |
| 224 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 225 | [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], |
| 226 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
| 227 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], |
| 228 | |
| 229 | [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 230 | [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 231 | [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 232 | [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
| 233 | |
| 234 | [ '%.40a', '3.14', |
| 235 | '0x1.91eb851eb851eb851eb851eb8500000000000000p+1' ], |
| 236 | |
| 237 | [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB85P+1' ], |
| 238 | ); |
| 239 | } else { |
| 240 | print "# no hexfloat tests\n"; |
| 241 | } |
| 242 | |
| 243 | plan tests => 1406 + ($Q ? 0 : 12) + @hexfloat; |
| 244 | |
| 245 | use strict; |
| 246 | use Config; |
| 247 | |
| 248 | is( |
| 249 | sprintf("%.40g ",0.01), |
| 250 | sprintf("%.40g", 0.01)." ", |
| 251 | q(the sprintf "%.<number>g" optimization) |
| 252 | ); |
| 253 | is( |
| 254 | sprintf("%.40f ",0.01), |
| 255 | sprintf("%.40f", 0.01)." ", |
| 256 | q(the sprintf "%.<number>f" optimization) |
| 257 | ); |
| 258 | |
| 259 | # cases of $i > 1 are against [perl #39126] |
| 260 | for my $i (1, 5, 10, 20, 50, 100) { |
| 261 | chop(my $utf8_format = "%-*s\x{100}"); |
| 262 | my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT |
| 263 | my $expect = $string." "x$i; # followed by 2*$i spaces |
| 264 | is(sprintf($utf8_format, 3*$i, $string), $expect, |
| 265 | "width calculation under utf8 upgrade, length=$i"); |
| 266 | } |
| 267 | |
| 268 | # check simultaneous width & precision with wide characters |
| 269 | for my $i (1, 3, 5, 10) { |
| 270 | my $string = "\x{0410}"x($i+10); # cyrillic capital A |
| 271 | my $expect = "\x{0410}"x$i; # cut down to exactly $i characters |
| 272 | my $format = "%$i.${i}s"; |
| 273 | is(sprintf($format, $string), $expect, |
| 274 | "width & precision interplay with utf8 strings, length=$i"); |
| 275 | } |
| 276 | |
| 277 | # Used to mangle PL_sv_undef |
| 278 | fresh_perl_like( |
| 279 | 'print sprintf "xxx%n\n"; print undef', |
| 280 | qr/Modification of a read-only value attempted at - line 1\./, |
| 281 | { switches => [ '-w' ] }, |
| 282 | q(%n should not be able to modify read-only constants), |
| 283 | ); |
| 284 | |
| 285 | # check overflows |
| 286 | for (int(~0/2+1), ~0, "9999999999999999999") { |
| 287 | is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d"); |
| 288 | like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf"); |
| 289 | is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d"); |
| 290 | like($@, qr/^Integer overflow in format string for printf /, "overflow in printf"); |
| 291 | } |
| 292 | |
| 293 | # check %NNN$ for range bounds |
| 294 | { |
| 295 | my ($warn, $bad) = (0,0); |
| 296 | local $SIG{__WARN__} = sub { |
| 297 | if ($_[0] =~ /missing argument/i) { |
| 298 | $warn++ |
| 299 | } |
| 300 | else { |
| 301 | $bad++ |
| 302 | } |
| 303 | }; |
| 304 | |
| 305 | my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); |
| 306 | my $result = sprintf $fmt, qw(a b c d); |
| 307 | is($result, "abcd", "only four valid values in $fmt"); |
| 308 | is($warn, 36, "expected warnings"); |
| 309 | is($bad, 0, "unexpected warnings"); |
| 310 | } |
| 311 | |
| 312 | # Tests for "missing argument" and "redundant argument" warnings |
| 313 | { |
| 314 | my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); |
| 315 | local $SIG{__WARN__} = sub { |
| 316 | if ($_[0] =~ /missing argument/i) { |
| 317 | $warn_missing++ |
| 318 | } |
| 319 | elsif ($_[0] =~ /redundant argument/i) { |
| 320 | $warn_redundant++ |
| 321 | } |
| 322 | else { |
| 323 | $warn_bad++ |
| 324 | } |
| 325 | }; |
| 326 | |
| 327 | my @tests = ( |
| 328 | # The "", "%s", and "%-p" formats have special-case handling |
| 329 | # in sv.c |
| 330 | { |
| 331 | fmt => "", |
| 332 | args => [ qw( x ) ], |
| 333 | res => "", |
| 334 | m => 0, |
| 335 | r => 1, |
| 336 | }, |
| 337 | { |
| 338 | fmt => "%s", |
| 339 | args => [ qw( x y ) ], |
| 340 | res => "x", |
| 341 | m => 0, |
| 342 | r => 1, |
| 343 | }, |
| 344 | { |
| 345 | fmt => "%-p", |
| 346 | args => [ qw( x y ) ], |
| 347 | res => qr/^[0-9a-f]+$/as, |
| 348 | m => 0, |
| 349 | r => 1, |
| 350 | }, |
| 351 | # Other non-specialcased patterns |
| 352 | { |
| 353 | fmt => "%s : %s", |
| 354 | args => [ qw( a b c ) ], |
| 355 | res => "a : b", |
| 356 | m => 0, |
| 357 | r => 1, |
| 358 | }, |
| 359 | { |
| 360 | fmt => "%s : %s : %s", |
| 361 | args => [ qw( a b c d e ) ], |
| 362 | res => "a : b : c", |
| 363 | m => 0, |
| 364 | # Note how we'll only warn about redundant arguments once, |
| 365 | # even though both "d" and "e" are redundant... |
| 366 | r => 1, |
| 367 | }, |
| 368 | { |
| 369 | fmt => "%s : %s : %s", |
| 370 | args => [ ], |
| 371 | res => " : : ", |
| 372 | # ...But when arguments are missing we'll warn about every |
| 373 | # missing argument. This difference between the two |
| 374 | # warnings is a feature. |
| 375 | m => 3, |
| 376 | r => 0, |
| 377 | }, |
| 378 | |
| 379 | # Tests for format parameter indexes. |
| 380 | # |
| 381 | # Deciding what to do about these is a bit tricky, and so is |
| 382 | # "correctly" warning about missing arguments on them. |
| 383 | # |
| 384 | # Should we warn if you supply 4 arguments but only use |
| 385 | # argument 1,3 & 4? Or only if you supply 5 arguments and your |
| 386 | # highest used argument is 4? |
| 387 | # |
| 388 | # For some uses of this printf feature (e.g. i18n systems) |
| 389 | # it's a always a logic error to not print out every provided |
| 390 | # argument, but for some other uses skipping some might be a |
| 391 | # feature (although you could argue that then printf should be |
| 392 | # called as e.g: |
| 393 | # |
| 394 | # printf q[%1$s %3$s], x(), undef, z(); |
| 395 | # |
| 396 | # Instead of: |
| 397 | # |
| 398 | # printf q[%1$s %3$s], x(), y(), z(); |
| 399 | # |
| 400 | # Since calling the (possibly expensive) y() function is |
| 401 | # completely redundant there. |
| 402 | # |
| 403 | # We deal with all these potential problems by not even |
| 404 | # trying. If the pattern contains any format parameter indexes |
| 405 | # whatsoever we'll never warn about redundant arguments. |
| 406 | { |
| 407 | fmt => '%1$s : %2$s', |
| 408 | args => [ qw( x y z ) ], |
| 409 | res => "x : y", |
| 410 | m => 0, |
| 411 | r => 0, |
| 412 | }, |
| 413 | { |
| 414 | fmt => '%2$s : %4$s : %5$s', |
| 415 | args => [ qw( a b c d )], |
| 416 | res => "b : d : ", |
| 417 | m => 1, |
| 418 | r => 0, |
| 419 | }, |
| 420 | { |
| 421 | fmt => '%s : %1$s : %s', |
| 422 | args => [ qw( x y z ) ], |
| 423 | res => "x : x : y", |
| 424 | m => 0, |
| 425 | r => 0, |
| 426 | }, |
| 427 | |
| 428 | ); |
| 429 | |
| 430 | for my $i (0..$#tests) { |
| 431 | my $test = $tests[$i]; |
| 432 | my $result = sprintf $test->{fmt}, @{$test->{args}}; |
| 433 | |
| 434 | my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'"; |
| 435 | if (ref $test->{res} eq 'Regexp') { |
| 436 | like($result, $test->{res}, "$prefix got the right result"); |
| 437 | } else { |
| 438 | is($result, $test->{res}, "$prefix got the right result"); |
| 439 | } |
| 440 | is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings"); |
| 441 | is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings"); |
| 442 | is($warn_bad, 0, "$prefix No unknown warnings"); |
| 443 | |
| 444 | ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); |
| 445 | } |
| 446 | } |
| 447 | |
| 448 | { |
| 449 | foreach my $ord (0 .. 255) { |
| 450 | my $bad = 0; |
| 451 | local $SIG{__WARN__} = sub { |
| 452 | if ($_[0] !~ /^Invalid conversion in sprintf/) { |
| 453 | warn $_[0]; |
| 454 | $bad++; |
| 455 | } |
| 456 | }; |
| 457 | my $r = eval {sprintf '%v' . chr $ord}; |
| 458 | is ($bad, 0, "pattern '%v' . chr $ord"); |
| 459 | } |
| 460 | } |
| 461 | |
| 462 | sub mysprintf_int_flags { |
| 463 | my ($fmt, $num) = @_; |
| 464 | die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/; |
| 465 | my $flag = $1; |
| 466 | my $width = $2; |
| 467 | my $sign = $num < 0 ? '-' : |
| 468 | $flag =~ /\+/ ? '+' : |
| 469 | $flag =~ /\ / ? ' ' : |
| 470 | ''; |
| 471 | my $abs = abs($num); |
| 472 | my $padlen = $width - length($sign.$abs); |
| 473 | return |
| 474 | $flag =~ /0/ && $flag !~ /-/ # do zero padding |
| 475 | ? $sign . '0' x $padlen . $abs |
| 476 | : $flag =~ /-/ # left or right |
| 477 | ? $sign . $abs . ' ' x $padlen |
| 478 | : ' ' x $padlen . $sign . $abs; |
| 479 | } |
| 480 | |
| 481 | # Whole tests for "%4d" with 2 to 4 flags; |
| 482 | # total counts: 3 * (4**2 + 4**3 + 4**4) == 1008 |
| 483 | |
| 484 | my @flags = ("-", "+", " ", "0"); |
| 485 | for my $num (0, -1, 1) { |
| 486 | for my $f1 (@flags) { |
| 487 | for my $f2 (@flags) { |
| 488 | for my $f3 ('', @flags) { # '' for doubled flags |
| 489 | my $flag = $f1.$f2.$f3; |
| 490 | my $width = 4; |
| 491 | my $fmt = '%'."${flag}${width}d"; |
| 492 | my $result = sprintf($fmt, $num); |
| 493 | my $expect = mysprintf_int_flags($fmt, $num); |
| 494 | is($result, $expect, qq/sprintf("$fmt",$num)/); |
| 495 | |
| 496 | next if $f3 eq ''; |
| 497 | |
| 498 | for my $f4 (@flags) { # quadrupled flags |
| 499 | my $flag = $f1.$f2.$f3.$f4; |
| 500 | my $fmt = '%'."${flag}${width}d"; |
| 501 | my $result = sprintf($fmt, $num); |
| 502 | my $expect = mysprintf_int_flags($fmt, $num); |
| 503 | is($result, $expect, qq/sprintf("$fmt",$num)/); |
| 504 | } |
| 505 | } |
| 506 | } |
| 507 | } |
| 508 | } |
| 509 | |
| 510 | # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] |
| 511 | foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN |
| 512 | eval { my $f = sprintf("%f", $n); }; |
| 513 | is $@, "", "sprintf(\"%f\", $n)"; |
| 514 | } |
| 515 | |
| 516 | # test %ll formats with and without HAS_QUAD |
| 517 | my @tests = ( |
| 518 | [ '%lld' => [qw( 4294967296 -100000000000000 )] ], |
| 519 | [ '%lli' => [qw( 4294967296 -100000000000000 )] ], |
| 520 | [ '%llu' => [qw( 4294967296 100000000000000 )] ], |
| 521 | [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], |
| 522 | [ '%Li' => [qw( 4294967296 -100000000000000 )] ], |
| 523 | [ '%Lu' => [qw( 4294967296 100000000000000 )] ], |
| 524 | ); |
| 525 | |
| 526 | for my $t (@tests) { |
| 527 | my($fmt, $nums) = @$t; |
| 528 | for my $num (@$nums) { |
| 529 | my $w = ''; |
| 530 | local $SIG{__WARN__} = sub { $w .= shift }; |
| 531 | my $sprintf_got = sprintf($fmt, $num); |
| 532 | if ($Q) { |
| 533 | is($sprintf_got, $num, "quad: $fmt -> $num"); |
| 534 | is($w, '', "no warnings for: $fmt -> $num"); |
| 535 | } else { |
| 536 | is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt"); |
| 537 | like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt"); |
| 538 | like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt"); |
| 539 | } |
| 540 | } |
| 541 | } |
| 542 | |
| 543 | # Check unicode vs byte length |
| 544 | for my $width (1,2,3,4,5,6,7) { |
| 545 | for my $precis (1,2,3,4,5,6,7) { |
| 546 | my $v = "\x{20ac}\x{20ac}"; |
| 547 | my $format = "%" . $width . "." . $precis . "s"; |
| 548 | my $chars = ($precis > 2 ? 2 : $precis); |
| 549 | my $space = ($width < 2 ? 0 : $width - $chars); |
| 550 | fresh_perl_is( |
| 551 | 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', |
| 552 | "$space$chars", |
| 553 | {}, |
| 554 | q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), |
| 555 | ); |
| 556 | } |
| 557 | } |
| 558 | |
| 559 | # Overload count |
| 560 | package o { use overload '""', sub { ++our $count; $_[0][0]; } } |
| 561 | my $o = bless ["\x{100}"], o::; |
| 562 | () = sprintf "%1s", $o; |
| 563 | is $o::count, '1', 'sprinf %1s overload count'; |
| 564 | $o::count = 0; |
| 565 | () = sprintf "%.1s", $o; |
| 566 | is $o::count, '1', 'sprinf %.1s overload count'; |
| 567 | |
| 568 | for my $t (@hexfloat) { |
| 569 | my ($format, $arg, $expected) = @$t; |
| 570 | $arg = eval $arg; |
| 571 | my $result = sprintf($format, $arg); |
| 572 | my $ok = $result eq $expected; |
| 573 | unless ($ok) { |
| 574 | # It seems that there can be difference in the last bits: |
| 575 | # [perl #122578] |
| 576 | # got "0x1.5bf0a8b14576ap+1" |
| 577 | # expected "0x1.5bf0a8b145769p+1" |
| 578 | # (Android on ARM) |
| 579 | # |
| 580 | # Exact cause unknown but suspecting different fp rounding modes, |
| 581 | # (towards zero? towards +inf? towards -inf?) about which Perl |
| 582 | # is blissfully unaware. |
| 583 | # |
| 584 | # Try extracting one (or sometimes two) last mantissa |
| 585 | # hexdigits, and see if they differ in value by one. |
| 586 | my ($rh, $eh) = ($result, $expected); |
| 587 | sub extract_prefix { |
| 588 | ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1; |
| 589 | } |
| 590 | my $rp = extract_prefix($rh); |
| 591 | my $ep = extract_prefix($eh); |
| 592 | print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n"; |
| 593 | if ($rp eq $ep) { # If prefixes match. |
| 594 | sub extract_exponent { |
| 595 | ($_[0] =~ s/([pP][+-]?\d+)//) && return $1; |
| 596 | } |
| 597 | my $re = extract_exponent($rh); |
| 598 | my $ee = extract_exponent($eh); |
| 599 | print "# re = $re, ee = $ee (rh $rh, eh $eh)\n"; |
| 600 | if ($re eq $ee) { # If exponents match. |
| 601 | # Remove the common prefix of the mantissa bits. |
| 602 | my $la = length($rh); |
| 603 | my $lb = length($eh); |
| 604 | my $i; |
| 605 | for ($i = 0; $i < $la && $i < $lb; $i++) { |
| 606 | last if substr($rh, $i, 1) ne substr($eh, $i, 1); |
| 607 | } |
| 608 | $rh = substr($rh, $i); |
| 609 | $eh = substr($eh, $i); |
| 610 | print "# (rh $rh, eh $eh)\n"; |
| 611 | if ($rh ne $eh) { |
| 612 | # If necessary, pad the shorter one on the right |
| 613 | # with one zero (for example "...1f" vs "...2", |
| 614 | # we want to compare "1f" to "20"). |
| 615 | if (length $rh < length $eh) { |
| 616 | $rh .= '0'; |
| 617 | } elsif (length $eh < length $rh) { |
| 618 | $eh .= '0'; |
| 619 | } |
| 620 | print "# (rh $rh, eh $eh)\n"; |
| 621 | if (length $eh == length $rh) { |
| 622 | if (abs(hex($eh) - hex($rh)) == 1) { |
| 623 | $ok = 1; |
| 624 | } |
| 625 | } |
| 626 | } |
| 627 | } |
| 628 | } |
| 629 | } |
| 630 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); |
| 631 | } |