Commit | Line | Data |
---|---|---|
1d917b39 RGS |
1 | #!./perl -w |
2 | ||
6715405f FC |
3 | # Tests for sprintf that do not fit the format of sprintf.t. |
4 | ||
1d917b39 RGS |
5 | BEGIN { |
6 | chdir 't' if -d 't'; | |
7 | @INC = '../lib'; | |
8 | require './test.pl'; | |
9 | } | |
10 | ||
43d7f0da AB |
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 | ||
40bca5ae JH |
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 | ( | |
f7a48a8c | 24 | # IEEE-754 64-bit ("double precision"), the most common out there |
40bca5ae JH |
25 | ($Config{uvsize} == 8 && $Config{nv_preserves_uv_bits} == 53) |
26 | || | |
c1b97dd3 JH |
27 | # If we have a quad we can still get the mantissa bits. |
28 | ($Config{uvsize} == 4 && $Config{d_quad}) | |
40bca5ae JH |
29 | ) |
30 | ) { | |
f7a48a8c | 31 | @hexfloat = ( |
40bca5ae JH |
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 | ||
f7a48a8c JH |
73 | [ '%.40a', '3.14', |
74 | '0x1.91eb851eb851f000000000000000000000000000p+1' ], | |
75 | ||
40bca5ae JH |
76 | [ '%A', '3.14', '0X1.91EB851EB851FP+1' ], |
77 | ); | |
c1b97dd3 | 78 | } elsif (($Config{nvsize} == 16 || $Config{nvsize} == 12) && |
f7a48a8c JH |
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 | |
c1b97dd3 JH |
82 | (pack("F", 0.1) =~ /^\xCD/ || # LE |
83 | pack("F", 0.1) =~ /\xCD$/)) { # BE (if this ever happens) | |
f7a48a8c | 84 | @hexfloat = ( |
40bca5ae JH |
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 | ||
f7a48a8c JH |
126 | [ '%.40a', '3.14', |
127 | '0xc.8f5c28f5c28f5c30000000000000000000000000p-2' ], | |
128 | ||
40bca5ae JH |
129 | [ '%A', '3.14', '0XC.8F5C28F5C28F5C3P-2' ], |
130 | ); | |
f7a48a8c JH |
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 | |
f7a48a8c | 135 | (pack("F", 0.1) =~ /^\x9A\x99{6}/ || # LE |
6094cb95 | 136 | pack("F", 0.1) =~ /\x99{6}\x9A$/) # BE |
f7a48a8c JH |
137 | ) { |
138 | @hexfloat = ( | |
139 | [ '%a', '0', '0x1p-1' ], | |
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 && | |
0096dfab JH |
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 | |
f7a48a8c | 191 | ) { |
0096dfab JH |
192 | # XXX these values are actually only "single-double" since |
193 | # we currently do not know how to exactly handle the second | |
194 | # double. See the discussion in sv.c:S_hextract(). | |
f7a48a8c JH |
195 | @hexfloat = ( |
196 | [ '%a', '0', '0x1p-1' ], | |
197 | [ '%a', '1', '0x1p+0' ], | |
198 | [ '%a', '1.0', '0x1p+0' ], | |
199 | [ '%a', '0.5', '0x1p-1' ], | |
200 | [ '%a', '0.25', '0x1p-2' ], | |
201 | [ '%a', '0.75', '0x1.8p-1' ], | |
0096dfab | 202 | [ '%a', '3.14', '0x1.91eb851eb851fp+1' ], |
f7a48a8c | 203 | [ '%a', '-1', '-0x1p+0' ], |
0096dfab JH |
204 | [ '%a', '-3.14', '-0x1.91eb851eb851fp+1' ], |
205 | [ '%a', '0.1', '0x1.999999999999ap-4' ], | |
206 | [ '%a', '1/7', '0x1.2492492492492p-3' ], | |
10decdeb | 207 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcdp+0' ], |
0096dfab | 208 | [ '%a', 'exp(1)', '0x1.5bf0a8b145769p+1' ], |
f7a48a8c JH |
209 | [ '%a', '2**-10', '0x1p-10' ], |
210 | [ '%a', '2**10', '0x1p+10' ], | |
0096dfab | 211 | [ '%a', '1e-09', '0x1.12e0be826d695p-30' ], |
f7a48a8c JH |
212 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
213 | ||
214 | [ '%#a', '1', '0x1.p+0' ], | |
215 | [ '%+a', '1', '+0x1p+0' ], | |
216 | [ '%+a', '-1', '-0x1p+0' ], | |
217 | [ '% a', '1', ' 0x1p+0' ], | |
218 | [ '% a', '-1', '-0x1p+0' ], | |
219 | ||
0096dfab JH |
220 | [ '%8a', '3.14', '0x1.91eb851eb851fp+1' ], |
221 | [ '%13a', '3.14', '0x1.91eb851eb851fp+1' ], | |
222 | [ '%20a', '3.14', '0x1.91eb851eb851fp+1' ], | |
f7a48a8c JH |
223 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
224 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], | |
225 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], | |
0096dfab | 226 | [ '%.20a', '3.14', '0x1.91eb851eb851f0000000p+1' ], |
f7a48a8c | 227 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
0096dfab | 228 | [ '%20.15a', '3.14', '0x1.91eb851eb851f00p+1' ], |
f7a48a8c JH |
229 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
230 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], | |
231 | ||
0096dfab JH |
232 | [ '%30a', '3.14', ' 0x1.91eb851eb851fp+1' ], |
233 | [ '%-30a', '3.14', '0x1.91eb851eb851fp+1 ' ], | |
234 | [ '%030a', '3.14', '0x00000000001.91eb851eb851fp+1' ], | |
235 | [ '%-030a', '3.14', '0x1.91eb851eb851fp+1 ' ], | |
f7a48a8c JH |
236 | |
237 | [ '%.40a', '3.14', | |
0096dfab | 238 | '0x1.91eb851eb851f000000000000000000000000000p+1' ], |
f7a48a8c | 239 | |
0096dfab | 240 | [ '%A', '3.14', '0X1.91EB851EB851FP+1' ], |
f7a48a8c | 241 | ); |
40bca5ae JH |
242 | } else { |
243 | print "# no hexfloat tests\n"; | |
244 | } | |
245 | ||
246 | plan tests => 1406 + ($Q ? 0 : 12) + @hexfloat; | |
53f65a9e HS |
247 | |
248 | use strict; | |
249 | use Config; | |
1d917b39 RGS |
250 | |
251 | is( | |
252 | sprintf("%.40g ",0.01), | |
253 | sprintf("%.40g", 0.01)." ", | |
254 | q(the sprintf "%.<number>g" optimization) | |
255 | ); | |
256 | is( | |
257 | sprintf("%.40f ",0.01), | |
258 | sprintf("%.40f", 0.01)." ", | |
259 | q(the sprintf "%.<number>f" optimization) | |
260 | ); | |
cc61b222 TS |
261 | |
262 | # cases of $i > 1 are against [perl #39126] | |
263 | for my $i (1, 5, 10, 20, 50, 100) { | |
264 | chop(my $utf8_format = "%-*s\x{100}"); | |
265 | my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT | |
266 | my $expect = $string." "x$i; # followed by 2*$i spaces | |
267 | is(sprintf($utf8_format, 3*$i, $string), $expect, | |
268 | "width calculation under utf8 upgrade, length=$i"); | |
6c94ec8b | 269 | } |
fc7325bb | 270 | |
59b61096 AV |
271 | # check simultaneous width & precision with wide characters |
272 | for my $i (1, 3, 5, 10) { | |
273 | my $string = "\x{0410}"x($i+10); # cyrillic capital A | |
274 | my $expect = "\x{0410}"x$i; # cut down to exactly $i characters | |
275 | my $format = "%$i.${i}s"; | |
276 | is(sprintf($format, $string), $expect, | |
277 | "width & precision interplay with utf8 strings, length=$i"); | |
278 | } | |
279 | ||
fc7325bb | 280 | # Used to mangle PL_sv_undef |
7baa4690 | 281 | fresh_perl_like( |
fc7325bb | 282 | 'print sprintf "xxx%n\n"; print undef', |
aaa63dae | 283 | qr/Modification of a read-only value attempted at - line 1\./, |
fc7325bb GA |
284 | { switches => [ '-w' ] }, |
285 | q(%n should not be able to modify read-only constants), | |
863811b2 DM |
286 | ); |
287 | ||
2fba7546 | 288 | # check overflows |
45e52d63 | 289 | for (int(~0/2+1), ~0, "9999999999999999999") { |
2fba7546 GA |
290 | is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d"); |
291 | like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf"); | |
292 | is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d"); | |
94bbb3f4 | 293 | like($@, qr/^Integer overflow in format string for printf /, "overflow in printf"); |
2fba7546 | 294 | } |
863811b2 | 295 | |
2fba7546 | 296 | # check %NNN$ for range bounds |
863811b2 DM |
297 | { |
298 | my ($warn, $bad) = (0,0); | |
299 | local $SIG{__WARN__} = sub { | |
7baa4690 | 300 | if ($_[0] =~ /missing argument/i) { |
863811b2 DM |
301 | $warn++ |
302 | } | |
303 | else { | |
304 | $bad++ | |
305 | } | |
306 | }; | |
2fba7546 | 307 | |
45e52d63 | 308 | my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); |
2fba7546 GA |
309 | my $result = sprintf $fmt, qw(a b c d); |
310 | is($result, "abcd", "only four valid values in $fmt"); | |
863811b2 DM |
311 | is($warn, 36, "expected warnings"); |
312 | is($bad, 0, "unexpected warnings"); | |
313 | } | |
314 | ||
4077a6bc AB |
315 | # Tests for "missing argument" and "redundant argument" warnings |
316 | { | |
317 | my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); | |
318 | local $SIG{__WARN__} = sub { | |
319 | if ($_[0] =~ /missing argument/i) { | |
320 | $warn_missing++ | |
321 | } | |
322 | elsif ($_[0] =~ /redundant argument/i) { | |
323 | $warn_redundant++ | |
324 | } | |
325 | else { | |
326 | $warn_bad++ | |
327 | } | |
328 | }; | |
329 | ||
330 | my @tests = ( | |
331 | # The "", "%s", and "%-p" formats have special-case handling | |
332 | # in sv.c | |
333 | { | |
334 | fmt => "", | |
335 | args => [ qw( x ) ], | |
336 | res => "", | |
337 | m => 0, | |
338 | r => 1, | |
339 | }, | |
340 | { | |
341 | fmt => "%s", | |
342 | args => [ qw( x y ) ], | |
343 | res => "x", | |
344 | m => 0, | |
345 | r => 1, | |
346 | }, | |
347 | { | |
348 | fmt => "%-p", | |
349 | args => [ qw( x y ) ], | |
350 | res => qr/^[0-9a-f]+$/as, | |
351 | m => 0, | |
352 | r => 1, | |
353 | }, | |
354 | # Other non-specialcased patterns | |
355 | { | |
356 | fmt => "%s : %s", | |
357 | args => [ qw( a b c ) ], | |
358 | res => "a : b", | |
359 | m => 0, | |
360 | r => 1, | |
361 | }, | |
362 | { | |
363 | fmt => "%s : %s : %s", | |
364 | args => [ qw( a b c d e ) ], | |
365 | res => "a : b : c", | |
366 | m => 0, | |
367 | # Note how we'll only warn about redundant arguments once, | |
368 | # even though both "d" and "e" are redundant... | |
369 | r => 1, | |
370 | }, | |
371 | { | |
372 | fmt => "%s : %s : %s", | |
373 | args => [ ], | |
374 | res => " : : ", | |
375 | # ...But when arguments are missing we'll warn about every | |
376 | # missing argument. This difference between the two | |
377 | # warnings is a feature. | |
378 | m => 3, | |
379 | r => 0, | |
380 | }, | |
381 | ||
382 | # Tests for format parameter indexes. | |
383 | # | |
384 | # Deciding what to do about these is a bit tricky, and so is | |
385 | # "correctly" warning about missing arguments on them. | |
386 | # | |
387 | # Should we warn if you supply 4 arguments but only use | |
388 | # argument 1,3 & 4? Or only if you supply 5 arguments and your | |
389 | # highest used argument is 4? | |
390 | # | |
391 | # For some uses of this printf feature (e.g. i18n systems) | |
392 | # it's a always a logic error to not print out every provided | |
393 | # argument, but for some other uses skipping some might be a | |
394 | # feature (although you could argue that then printf should be | |
395 | # called as e.g: | |
396 | # | |
397 | # printf q[%1$s %3$s], x(), undef, z(); | |
398 | # | |
399 | # Instead of: | |
400 | # | |
401 | # printf q[%1$s %3$s], x(), y(), z(); | |
402 | # | |
403 | # Since calling the (possibly expensive) y() function is | |
404 | # completely redundant there. | |
405 | # | |
406 | # We deal with all these potential problems by not even | |
407 | # trying. If the pattern contains any format parameter indexes | |
408 | # whatsoever we'll never warn about redundant arguments. | |
409 | { | |
410 | fmt => '%1$s : %2$s', | |
411 | args => [ qw( x y z ) ], | |
412 | res => "x : y", | |
413 | m => 0, | |
414 | r => 0, | |
415 | }, | |
416 | { | |
417 | fmt => '%2$s : %4$s : %5$s', | |
418 | args => [ qw( a b c d )], | |
419 | res => "b : d : ", | |
420 | m => 1, | |
421 | r => 0, | |
422 | }, | |
423 | { | |
424 | fmt => '%s : %1$s : %s', | |
425 | args => [ qw( x y z ) ], | |
426 | res => "x : x : y", | |
427 | m => 0, | |
428 | r => 0, | |
429 | }, | |
430 | ||
431 | ); | |
432 | ||
433 | for my $i (0..$#tests) { | |
434 | my $test = $tests[$i]; | |
435 | my $result = sprintf $test->{fmt}, @{$test->{args}}; | |
436 | ||
437 | my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'"; | |
438 | if (ref $test->{res} eq 'Regexp') { | |
439 | like($result, $test->{res}, "$prefix got the right result"); | |
440 | } else { | |
441 | is($result, $test->{res}, "$prefix got the right result"); | |
442 | } | |
443 | is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings"); | |
444 | is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings"); | |
445 | is($warn_bad, 0, "$prefix No unknown warnings"); | |
446 | ||
447 | ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); | |
448 | } | |
449 | } | |
450 | ||
343ef749 NC |
451 | { |
452 | foreach my $ord (0 .. 255) { | |
453 | my $bad = 0; | |
454 | local $SIG{__WARN__} = sub { | |
455 | if ($_[0] !~ /^Invalid conversion in sprintf/) { | |
456 | warn $_[0]; | |
457 | $bad++; | |
458 | } | |
459 | }; | |
460 | my $r = eval {sprintf '%v' . chr $ord}; | |
461 | is ($bad, 0, "pattern '%v' . chr $ord"); | |
462 | } | |
463 | } | |
9911cee9 TS |
464 | |
465 | sub mysprintf_int_flags { | |
466 | my ($fmt, $num) = @_; | |
467 | die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/; | |
468 | my $flag = $1; | |
469 | my $width = $2; | |
470 | my $sign = $num < 0 ? '-' : | |
471 | $flag =~ /\+/ ? '+' : | |
472 | $flag =~ /\ / ? ' ' : | |
473 | ''; | |
474 | my $abs = abs($num); | |
475 | my $padlen = $width - length($sign.$abs); | |
476 | return | |
477 | $flag =~ /0/ && $flag !~ /-/ # do zero padding | |
478 | ? $sign . '0' x $padlen . $abs | |
479 | : $flag =~ /-/ # left or right | |
480 | ? $sign . $abs . ' ' x $padlen | |
481 | : ' ' x $padlen . $sign . $abs; | |
482 | } | |
483 | ||
484 | # Whole tests for "%4d" with 2 to 4 flags; | |
485 | # total counts: 3 * (4**2 + 4**3 + 4**4) == 1008 | |
486 | ||
487 | my @flags = ("-", "+", " ", "0"); | |
488 | for my $num (0, -1, 1) { | |
489 | for my $f1 (@flags) { | |
490 | for my $f2 (@flags) { | |
491 | for my $f3 ('', @flags) { # '' for doubled flags | |
492 | my $flag = $f1.$f2.$f3; | |
493 | my $width = 4; | |
494 | my $fmt = '%'."${flag}${width}d"; | |
495 | my $result = sprintf($fmt, $num); | |
496 | my $expect = mysprintf_int_flags($fmt, $num); | |
497 | is($result, $expect, qq/sprintf("$fmt",$num)/); | |
498 | ||
499 | next if $f3 eq ''; | |
500 | ||
501 | for my $f4 (@flags) { # quadrupled flags | |
502 | my $flag = $f1.$f2.$f3.$f4; | |
503 | my $fmt = '%'."${flag}${width}d"; | |
504 | my $result = sprintf($fmt, $num); | |
505 | my $expect = mysprintf_int_flags($fmt, $num); | |
506 | is($result, $expect, qq/sprintf("$fmt",$num)/); | |
507 | } | |
508 | } | |
509 | } | |
510 | } | |
511 | } | |
512 | ||
9c2a5cfe B |
513 | # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] |
514 | foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN | |
515 | eval { my $f = sprintf("%f", $n); }; | |
516 | is $@, "", "sprintf(\"%f\", $n)"; | |
517 | } | |
53f65a9e HS |
518 | |
519 | # test %ll formats with and without HAS_QUAD | |
53f65a9e | 520 | my @tests = ( |
8ff953de MHM |
521 | [ '%lld' => [qw( 4294967296 -100000000000000 )] ], |
522 | [ '%lli' => [qw( 4294967296 -100000000000000 )] ], | |
523 | [ '%llu' => [qw( 4294967296 100000000000000 )] ], | |
524 | [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], | |
525 | [ '%Li' => [qw( 4294967296 -100000000000000 )] ], | |
526 | [ '%Lu' => [qw( 4294967296 100000000000000 )] ], | |
53f65a9e HS |
527 | ); |
528 | ||
529 | for my $t (@tests) { | |
8ff953de MHM |
530 | my($fmt, $nums) = @$t; |
531 | for my $num (@$nums) { | |
826af139 AB |
532 | my $w = ''; |
533 | local $SIG{__WARN__} = sub { $w .= shift }; | |
534 | my $sprintf_got = sprintf($fmt, $num); | |
535 | if ($Q) { | |
536 | is($sprintf_got, $num, "quad: $fmt -> $num"); | |
537 | is($w, '', "no warnings for: $fmt -> $num"); | |
538 | } else { | |
539 | is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt"); | |
540 | like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt"); | |
3101bb05 | 541 | like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt"); |
826af139 | 542 | } |
53f65a9e HS |
543 | } |
544 | } | |
545 | ||
9ef5ed94 AV |
546 | # Check unicode vs byte length |
547 | for my $width (1,2,3,4,5,6,7) { | |
548 | for my $precis (1,2,3,4,5,6,7) { | |
549 | my $v = "\x{20ac}\x{20ac}"; | |
550 | my $format = "%" . $width . "." . $precis . "s"; | |
551 | my $chars = ($precis > 2 ? 2 : $precis); | |
552 | my $space = ($width < 2 ? 0 : $width - $chars); | |
553 | fresh_perl_is( | |
554 | 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', | |
555 | "$space$chars", | |
556 | {}, | |
557 | q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), | |
558 | ); | |
559 | } | |
560 | } | |
667f6f15 FC |
561 | |
562 | # Overload count | |
563 | package o { use overload '""', sub { ++our $count; $_[0][0]; } } | |
564 | my $o = bless ["\x{100}"], o::; | |
565 | () = sprintf "%1s", $o; | |
566 | is $o::count, '1', 'sprinf %1s overload count'; | |
567 | $o::count = 0; | |
568 | () = sprintf "%.1s", $o; | |
569 | is $o::count, '1', 'sprinf %.1s overload count'; | |
40bca5ae JH |
570 | |
571 | for my $t (@hexfloat) { | |
572 | my ($format, $arg, $expected) = @$t; | |
573 | $arg = eval $arg; | |
574 | my $result = sprintf($format, $arg); | |
61b5c618 JH |
575 | my $ok = $result eq $expected; |
576 | unless ($ok) { | |
577 | # It seems that there can be difference in the last bits: | |
578 | # [perl #122578] | |
579 | # got "0x1.5bf0a8b14576ap+1" | |
580 | # expected "0x1.5bf0a8b145769p+1" | |
581 | # (Android on ARM) | |
582 | # | |
583 | # Exact cause unknown but suspecting different fp rounding modes, | |
584 | # (towards zero? towards +inf? towards -inf?) about which Perl | |
585 | # is blissfully unaware. | |
586 | # | |
587 | # Try extracting one (or sometimes two) last mantissa | |
588 | # hexdigits, and see if they differ in value by one. | |
589 | my ($rh, $eh) = ($result, $expected); | |
590 | sub extract_prefix { | |
13d235b3 | 591 | ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1; |
61b5c618 JH |
592 | } |
593 | my $rp = extract_prefix($rh); | |
594 | my $ep = extract_prefix($eh); | |
595 | print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n"; | |
596 | if ($rp eq $ep) { # If prefixes match. | |
597 | sub extract_exponent { | |
13d235b3 | 598 | ($_[0] =~ s/([pP][+-]?\d+)//) && return $1; |
61b5c618 JH |
599 | } |
600 | my $re = extract_exponent($rh); | |
601 | my $ee = extract_exponent($eh); | |
602 | print "# re = $re, ee = $ee (rh $rh, eh $eh)\n"; | |
603 | if ($re eq $ee) { # If exponents match. | |
604 | # Remove the common prefix of the mantissa bits. | |
605 | my $la = length($rh); | |
606 | my $lb = length($eh); | |
607 | my $i; | |
608 | for ($i = 0; $i < $la && $i < $lb; $i++) { | |
609 | last if substr($rh, $i, 1) ne substr($eh, $i, 1); | |
610 | } | |
611 | $rh = substr($rh, $i); | |
612 | $eh = substr($eh, $i); | |
613 | print "# (rh $rh, eh $eh)\n"; | |
614 | if ($rh ne $eh) { | |
615 | # If necessary, pad the shorter one on the right | |
616 | # with one zero (for example "...1f" vs "...2", | |
617 | # we want to compare "1f" to "20"). | |
618 | if (length $rh < length $eh) { | |
619 | $rh .= '0'; | |
620 | } elsif (length $eh < length $rh) { | |
621 | $eh .= '0'; | |
622 | } | |
623 | print "# (rh $rh, eh $eh)\n"; | |
624 | if (length $eh == length $rh) { | |
625 | if (abs(hex($eh) - hex($rh)) == 1) { | |
626 | $ok = 1; | |
627 | } | |
628 | } | |
629 | } | |
630 | } | |
631 | } | |
632 | } | |
633 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); | |
40bca5ae | 634 | } |