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 | ||
261d007a JH |
15 | my $doubledouble; |
16 | ||
40bca5ae JH |
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 | if ($Config{nvsize} == 8 && | |
25 | ( | |
f7a48a8c | 26 | # IEEE-754 64-bit ("double precision"), the most common out there |
40bca5ae JH |
27 | ($Config{uvsize} == 8 && $Config{nv_preserves_uv_bits} == 53) |
28 | || | |
c1b97dd3 JH |
29 | # If we have a quad we can still get the mantissa bits. |
30 | ($Config{uvsize} == 4 && $Config{d_quad}) | |
40bca5ae JH |
31 | ) |
32 | ) { | |
f7a48a8c | 33 | @hexfloat = ( |
40bca5ae JH |
34 | [ '%a', '0', '0x0p+0' ], |
35 | [ '%a', '1', '0x1p+0' ], | |
36 | [ '%a', '1.0', '0x1p+0' ], | |
37 | [ '%a', '0.5', '0x1p-1' ], | |
38 | [ '%a', '0.25', '0x1p-2' ], | |
39 | [ '%a', '0.75', '0x1.8p-1' ], | |
40 | [ '%a', '3.14', '0x1.91eb851eb851fp+1' ], | |
41 | [ '%a', '-1.0', '-0x1p+0' ], | |
42 | [ '%a', '-3.14', '-0x1.91eb851eb851fp+1' ], | |
43 | [ '%a', '0.1', '0x1.999999999999ap-4' ], | |
44 | [ '%a', '1/7', '0x1.2492492492492p-3' ], | |
45 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcdp+0' ], | |
46 | [ '%a', 'exp(1)', '0x1.5bf0a8b145769p+1' ], | |
47 | [ '%a', '2**-10', '0x1p-10' ], | |
48 | [ '%a', '2**10', '0x1p+10' ], | |
49 | [ '%a', '1e-9', '0x1.12e0be826d695p-30' ], | |
50 | [ '%a', '1e9', '0x1.dcd65p+29' ], | |
51 | ||
52 | [ '%#a', '1', '0x1.p+0' ], | |
53 | [ '%+a', '1', '+0x1p+0' ], | |
54 | [ '%+a', '-1', '-0x1p+0' ], | |
55 | [ '% a', ' 1', ' 0x1p+0' ], | |
56 | [ '% a', '-1', '-0x1p+0' ], | |
57 | ||
58 | [ '%8a', '3.14', '0x1.91eb851eb851fp+1' ], | |
59 | [ '%13a', '3.14', '0x1.91eb851eb851fp+1' ], | |
60 | [ '%20a', '3.14', '0x1.91eb851eb851fp+1' ], | |
61 | [ '%.4a', '3.14', '0x1.91ecp+1' ], | |
62 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], | |
63 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], | |
64 | [ '%.20a', '3.14', '0x1.91eb851eb851f0000000p+1' ], | |
65 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], | |
66 | [ '%20.15a', '3.14', '0x1.91eb851eb851f00p+1' ], | |
67 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], | |
68 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], | |
69 | ||
454ce668 JH |
70 | [ '%.13a', '1', '0x1.0000000000000p+0' ], |
71 | [ '%.13a', '-1', '-0x1.0000000000000p+0' ], | |
798a7a50 | 72 | [ '%.13a', '0', '0x0.0000000000000p+0' ], |
454ce668 | 73 | |
40bca5ae JH |
74 | [ '%30a', '3.14', ' 0x1.91eb851eb851fp+1' ], |
75 | [ '%-30a', '3.14', '0x1.91eb851eb851fp+1 ' ], | |
76 | [ '%030a', '3.14', '0x00000000001.91eb851eb851fp+1' ], | |
77 | [ '%-030a', '3.14', '0x1.91eb851eb851fp+1 ' ], | |
78 | ||
f7a48a8c JH |
79 | [ '%.40a', '3.14', |
80 | '0x1.91eb851eb851f000000000000000000000000000p+1' ], | |
81 | ||
40bca5ae JH |
82 | [ '%A', '3.14', '0X1.91EB851EB851FP+1' ], |
83 | ); | |
c1b97dd3 | 84 | } elsif (($Config{nvsize} == 16 || $Config{nvsize} == 12) && |
f7a48a8c JH |
85 | # 80-bit ("extended precision") long double, pack F is the NV |
86 | # cd cc cc cc cc cc cc cc fb bf 00 00 00 00 00 00 | |
87 | # cd cc cc cc cc cc cc cc fb bf 00 00 | |
c1b97dd3 JH |
88 | (pack("F", 0.1) =~ /^\xCD/ || # LE |
89 | pack("F", 0.1) =~ /\xCD$/)) { # BE (if this ever happens) | |
f7a48a8c | 90 | @hexfloat = ( |
40bca5ae JH |
91 | [ '%a', '0', '0x0p+0' ], |
92 | [ '%a', '1', '0x8p-3' ], | |
93 | [ '%a', '1.0', '0x8p-3' ], | |
94 | [ '%a', '0.5', '0x8p-4' ], | |
95 | [ '%a', '0.25', '0x8p-5' ], | |
96 | [ '%a', '0.75', '0xcp-4' ], | |
97 | [ '%a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], | |
98 | [ '%a', '-1.0', '-0x8p-3' ], | |
99 | [ '%a', '-3.14', '-0xc.8f5c28f5c28f5c3p-2' ], | |
100 | [ '%a', '0.1', '0xc.ccccccccccccccdp-7' ], | |
101 | [ '%a', '1/7', '0x9.249249249249249p-6' ], | |
102 | [ '%a', 'sqrt(2)', '0xb.504f333f9de6484p-3' ], | |
103 | [ '%a', 'exp(1)', '0xa.df85458a2bb4a9bp-2' ], | |
104 | [ '%a', '2**-10', '0x8p-13' ], | |
105 | [ '%a', '2**10', '0x8p+7' ], | |
106 | [ '%a', '1e-9', '0x8.9705f4136b4a597p-33' ], | |
107 | [ '%a', '1e9', '0xe.e6b28p+26' ], | |
108 | ||
109 | [ '%#a', '1', '0x8.p-3' ], | |
110 | [ '%+a', '1', '+0x8p-3' ], | |
111 | [ '%+a', '-1', '-0x8p-3' ], | |
112 | [ '% a', ' 1', ' 0x8p-3' ], | |
113 | [ '% a', '-1', '-0x8p-3' ], | |
114 | ||
115 | [ '%8a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], | |
116 | [ '%13a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], | |
117 | [ '%20a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], | |
118 | [ '%.4a', '3.14', '0xc.8f5cp-2' ], | |
119 | [ '%.5a', '3.14', '0xc.8f5c3p-2' ], | |
120 | [ '%.6a', '3.14', '0xc.8f5c29p-2' ], | |
121 | [ '%.20a', '3.14', '0xc.8f5c28f5c28f5c300000p-2' ], | |
122 | [ '%20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], | |
123 | [ '%20.15a', '3.14', '0xc.8f5c28f5c28f5c3p-2' ], | |
124 | [ '% 20.10a', '3.14', ' 0xc.8f5c28f5c3p-2' ], | |
125 | [ '%020.10a', '3.14', '0x000c.8f5c28f5c3p-2' ], | |
126 | ||
127 | [ '%30a', '3.14', ' 0xc.8f5c28f5c28f5c3p-2' ], | |
128 | [ '%-30a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], | |
129 | [ '%030a', '3.14', '0x00000000c.8f5c28f5c28f5c3p-2' ], | |
130 | [ '%-030a', '3.14', '0xc.8f5c28f5c28f5c3p-2 ' ], | |
131 | ||
f7a48a8c JH |
132 | [ '%.40a', '3.14', |
133 | '0xc.8f5c28f5c28f5c30000000000000000000000000p-2' ], | |
134 | ||
40bca5ae JH |
135 | [ '%A', '3.14', '0XC.8F5C28F5C28F5C3P-2' ], |
136 | ); | |
f7a48a8c JH |
137 | } elsif ( |
138 | # IEEE 754 128-bit ("quadruple precision"), e.g. IA-64 (Itanium) in VMS | |
139 | $Config{nvsize} == 16 && | |
140 | # 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f (LE), pack F is the NV | |
f7a48a8c | 141 | (pack("F", 0.1) =~ /^\x9A\x99{6}/ || # LE |
6094cb95 | 142 | pack("F", 0.1) =~ /\x99{6}\x9A$/) # BE |
f7a48a8c JH |
143 | ) { |
144 | @hexfloat = ( | |
53153bbf | 145 | [ '%a', '0', '0x0p+0' ], |
f7a48a8c JH |
146 | [ '%a', '1', '0x1p+0' ], |
147 | [ '%a', '1.0', '0x1p+0' ], | |
148 | [ '%a', '0.5', '0x1p-1' ], | |
149 | [ '%a', '0.25', '0x1p-2' ], | |
150 | [ '%a', '0.75', '0x1.8p-1' ], | |
151 | [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
152 | [ '%a', '-1', '-0x1p+0' ], | |
153 | [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
154 | [ '%a', '0.1', '0x1.999999999999999999999999999ap-4' ], | |
155 | [ '%a', '1/7', '0x1.2492492492492492492492492492p-3' ], | |
156 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea95p+0' ], | |
157 | [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e7ap+1' ], | |
158 | [ '%a', '2**-10', '0x1p-10' ], | |
159 | [ '%a', '2**10', '0x1p+10' ], | |
160 | [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f12ap-30' ], | |
161 | [ '%a', '1e9', '0x1.dcd65p+29' ], | |
162 | ||
163 | [ '%#a', '1', '0x1.p+0' ], | |
164 | [ '%+a', '1', '+0x1p+0' ], | |
165 | [ '%+a', '-1', '-0x1p+0' ], | |
166 | [ '% a', '1', ' 0x1p+0' ], | |
167 | [ '% a', '-1', '-0x1p+0' ], | |
168 | ||
169 | [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
170 | [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
171 | [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
172 | [ '%.4a', '3.14', '0x1.91ecp+1' ], | |
173 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], | |
174 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], | |
175 | [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], | |
176 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], | |
177 | [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], | |
178 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], | |
179 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], | |
180 | ||
181 | [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
182 | [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
183 | [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
184 | [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ], | |
185 | ||
186 | [ '%.40a', '3.14', | |
187 | '0x1.91eb851eb851eb851eb851eb851f000000000000p+1' ], | |
188 | ||
189 | [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB851FP+1' ], | |
190 | ); | |
191 | } elsif ( | |
192 | # "double-double", two 64-bit doubles end to end | |
193 | $Config{nvsize} == 16 && | |
0096dfab JH |
194 | # bf b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE), pack F is the NV |
195 | (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ || # LE | |
196 | pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/) # BE | |
f7a48a8c | 197 | ) { |
261d007a | 198 | $doubledouble = 1; |
f7a48a8c | 199 | @hexfloat = ( |
d07e3b4b | 200 | [ '%a', '0', '0x0p+0' ], |
f7a48a8c JH |
201 | [ '%a', '1', '0x1p+0' ], |
202 | [ '%a', '1.0', '0x1p+0' ], | |
203 | [ '%a', '0.5', '0x1p-1' ], | |
204 | [ '%a', '0.25', '0x1p-2' ], | |
205 | [ '%a', '0.75', '0x1.8p-1' ], | |
d07e3b4b JH |
206 | [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
207 | [ '%a', '-1', '-0x0p+0' ], | |
208 | [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb85p+1' ], | |
209 | [ '%a', '0.1', '0x1.999999999999999999999999998p-4' ], | |
210 | [ '%a', '1/7', '0x1.249249249249249249249249248p-3' ], | |
211 | [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea8p+0' ], | |
2804f8c1 | 212 | [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e8p+1' ], |
f7a48a8c JH |
213 | [ '%a', '2**-10', '0x1p-10' ], |
214 | [ '%a', '2**10', '0x1p+10' ], | |
d07e3b4b | 215 | [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f14p-30' ], |
f7a48a8c JH |
216 | [ '%a', '1e9', '0x1.dcd65p+29' ], |
217 | ||
218 | [ '%#a', '1', '0x1.p+0' ], | |
219 | [ '%+a', '1', '+0x1p+0' ], | |
220 | [ '%+a', '-1', '-0x1p+0' ], | |
221 | [ '% a', '1', ' 0x1p+0' ], | |
222 | [ '% a', '-1', '-0x1p+0' ], | |
223 | ||
d07e3b4b JH |
224 | [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
225 | [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], | |
226 | [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], | |
f7a48a8c JH |
227 | [ '%.4a', '3.14', '0x1.91ecp+1' ], |
228 | [ '%.5a', '3.14', '0x1.91eb8p+1' ], | |
229 | [ '%.6a', '3.14', '0x1.91eb85p+1' ], | |
d07e3b4b | 230 | [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], |
f7a48a8c | 231 | [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
d07e3b4b | 232 | [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], |
f7a48a8c JH |
233 | [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], |
234 | [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], | |
235 | ||
d07e3b4b JH |
236 | [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], |
237 | [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], | |
238 | [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], | |
239 | [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], | |
f7a48a8c JH |
240 | |
241 | [ '%.40a', '3.14', | |
d07e3b4b | 242 | '0x1.91eb851eb851eb851eb851eb8500000000000000p+1' ], |
f7a48a8c | 243 | |
d07e3b4b | 244 | [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB85P+1' ], |
f7a48a8c | 245 | ); |
40bca5ae JH |
246 | } else { |
247 | print "# no hexfloat tests\n"; | |
248 | } | |
249 | ||
eba98284 | 250 | plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 12; |
53f65a9e HS |
251 | |
252 | use strict; | |
253 | use Config; | |
1d917b39 RGS |
254 | |
255 | is( | |
256 | sprintf("%.40g ",0.01), | |
257 | sprintf("%.40g", 0.01)." ", | |
258 | q(the sprintf "%.<number>g" optimization) | |
259 | ); | |
260 | is( | |
261 | sprintf("%.40f ",0.01), | |
262 | sprintf("%.40f", 0.01)." ", | |
263 | q(the sprintf "%.<number>f" optimization) | |
264 | ); | |
cc61b222 TS |
265 | |
266 | # cases of $i > 1 are against [perl #39126] | |
267 | for my $i (1, 5, 10, 20, 50, 100) { | |
268 | chop(my $utf8_format = "%-*s\x{100}"); | |
269 | my $string = "\xB4"x$i; # latin1 ACUTE or ebcdic COPYRIGHT | |
270 | my $expect = $string." "x$i; # followed by 2*$i spaces | |
271 | is(sprintf($utf8_format, 3*$i, $string), $expect, | |
272 | "width calculation under utf8 upgrade, length=$i"); | |
6c94ec8b | 273 | } |
fc7325bb | 274 | |
59b61096 AV |
275 | # check simultaneous width & precision with wide characters |
276 | for my $i (1, 3, 5, 10) { | |
277 | my $string = "\x{0410}"x($i+10); # cyrillic capital A | |
278 | my $expect = "\x{0410}"x$i; # cut down to exactly $i characters | |
279 | my $format = "%$i.${i}s"; | |
280 | is(sprintf($format, $string), $expect, | |
281 | "width & precision interplay with utf8 strings, length=$i"); | |
282 | } | |
283 | ||
fc7325bb | 284 | # Used to mangle PL_sv_undef |
7baa4690 | 285 | fresh_perl_like( |
fc7325bb | 286 | 'print sprintf "xxx%n\n"; print undef', |
aaa63dae | 287 | qr/Modification of a read-only value attempted at - line 1\./, |
fc7325bb GA |
288 | { switches => [ '-w' ] }, |
289 | q(%n should not be able to modify read-only constants), | |
863811b2 DM |
290 | ); |
291 | ||
2fba7546 | 292 | # check overflows |
45e52d63 | 293 | for (int(~0/2+1), ~0, "9999999999999999999") { |
2fba7546 GA |
294 | is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d"); |
295 | like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf"); | |
296 | is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d"); | |
94bbb3f4 | 297 | like($@, qr/^Integer overflow in format string for printf /, "overflow in printf"); |
2fba7546 | 298 | } |
863811b2 | 299 | |
2fba7546 | 300 | # check %NNN$ for range bounds |
863811b2 DM |
301 | { |
302 | my ($warn, $bad) = (0,0); | |
303 | local $SIG{__WARN__} = sub { | |
7baa4690 | 304 | if ($_[0] =~ /missing argument/i) { |
863811b2 DM |
305 | $warn++ |
306 | } | |
307 | else { | |
308 | $bad++ | |
309 | } | |
310 | }; | |
2fba7546 | 311 | |
45e52d63 | 312 | my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); |
2fba7546 GA |
313 | my $result = sprintf $fmt, qw(a b c d); |
314 | is($result, "abcd", "only four valid values in $fmt"); | |
863811b2 DM |
315 | is($warn, 36, "expected warnings"); |
316 | is($bad, 0, "unexpected warnings"); | |
317 | } | |
318 | ||
4077a6bc AB |
319 | # Tests for "missing argument" and "redundant argument" warnings |
320 | { | |
321 | my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); | |
322 | local $SIG{__WARN__} = sub { | |
323 | if ($_[0] =~ /missing argument/i) { | |
324 | $warn_missing++ | |
325 | } | |
326 | elsif ($_[0] =~ /redundant argument/i) { | |
327 | $warn_redundant++ | |
328 | } | |
329 | else { | |
330 | $warn_bad++ | |
331 | } | |
332 | }; | |
333 | ||
334 | my @tests = ( | |
335 | # The "", "%s", and "%-p" formats have special-case handling | |
336 | # in sv.c | |
337 | { | |
338 | fmt => "", | |
339 | args => [ qw( x ) ], | |
340 | res => "", | |
341 | m => 0, | |
342 | r => 1, | |
343 | }, | |
344 | { | |
345 | fmt => "%s", | |
346 | args => [ qw( x y ) ], | |
347 | res => "x", | |
348 | m => 0, | |
349 | r => 1, | |
350 | }, | |
351 | { | |
352 | fmt => "%-p", | |
353 | args => [ qw( x y ) ], | |
354 | res => qr/^[0-9a-f]+$/as, | |
355 | m => 0, | |
356 | r => 1, | |
357 | }, | |
358 | # Other non-specialcased patterns | |
359 | { | |
360 | fmt => "%s : %s", | |
361 | args => [ qw( a b c ) ], | |
362 | res => "a : b", | |
363 | m => 0, | |
364 | r => 1, | |
365 | }, | |
366 | { | |
367 | fmt => "%s : %s : %s", | |
368 | args => [ qw( a b c d e ) ], | |
369 | res => "a : b : c", | |
370 | m => 0, | |
371 | # Note how we'll only warn about redundant arguments once, | |
372 | # even though both "d" and "e" are redundant... | |
373 | r => 1, | |
374 | }, | |
375 | { | |
376 | fmt => "%s : %s : %s", | |
377 | args => [ ], | |
378 | res => " : : ", | |
379 | # ...But when arguments are missing we'll warn about every | |
380 | # missing argument. This difference between the two | |
381 | # warnings is a feature. | |
382 | m => 3, | |
383 | r => 0, | |
384 | }, | |
385 | ||
386 | # Tests for format parameter indexes. | |
387 | # | |
388 | # Deciding what to do about these is a bit tricky, and so is | |
389 | # "correctly" warning about missing arguments on them. | |
390 | # | |
391 | # Should we warn if you supply 4 arguments but only use | |
392 | # argument 1,3 & 4? Or only if you supply 5 arguments and your | |
393 | # highest used argument is 4? | |
394 | # | |
395 | # For some uses of this printf feature (e.g. i18n systems) | |
396 | # it's a always a logic error to not print out every provided | |
397 | # argument, but for some other uses skipping some might be a | |
398 | # feature (although you could argue that then printf should be | |
399 | # called as e.g: | |
400 | # | |
401 | # printf q[%1$s %3$s], x(), undef, z(); | |
402 | # | |
403 | # Instead of: | |
404 | # | |
405 | # printf q[%1$s %3$s], x(), y(), z(); | |
406 | # | |
407 | # Since calling the (possibly expensive) y() function is | |
408 | # completely redundant there. | |
409 | # | |
410 | # We deal with all these potential problems by not even | |
411 | # trying. If the pattern contains any format parameter indexes | |
412 | # whatsoever we'll never warn about redundant arguments. | |
413 | { | |
414 | fmt => '%1$s : %2$s', | |
415 | args => [ qw( x y z ) ], | |
416 | res => "x : y", | |
417 | m => 0, | |
418 | r => 0, | |
419 | }, | |
420 | { | |
421 | fmt => '%2$s : %4$s : %5$s', | |
422 | args => [ qw( a b c d )], | |
423 | res => "b : d : ", | |
424 | m => 1, | |
425 | r => 0, | |
426 | }, | |
427 | { | |
428 | fmt => '%s : %1$s : %s', | |
429 | args => [ qw( x y z ) ], | |
430 | res => "x : x : y", | |
431 | m => 0, | |
432 | r => 0, | |
433 | }, | |
434 | ||
435 | ); | |
436 | ||
437 | for my $i (0..$#tests) { | |
438 | my $test = $tests[$i]; | |
439 | my $result = sprintf $test->{fmt}, @{$test->{args}}; | |
440 | ||
441 | my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'"; | |
442 | if (ref $test->{res} eq 'Regexp') { | |
443 | like($result, $test->{res}, "$prefix got the right result"); | |
444 | } else { | |
445 | is($result, $test->{res}, "$prefix got the right result"); | |
446 | } | |
447 | is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings"); | |
448 | is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings"); | |
449 | is($warn_bad, 0, "$prefix No unknown warnings"); | |
450 | ||
451 | ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); | |
452 | } | |
453 | } | |
454 | ||
343ef749 NC |
455 | { |
456 | foreach my $ord (0 .. 255) { | |
457 | my $bad = 0; | |
458 | local $SIG{__WARN__} = sub { | |
459 | if ($_[0] !~ /^Invalid conversion in sprintf/) { | |
460 | warn $_[0]; | |
461 | $bad++; | |
462 | } | |
463 | }; | |
464 | my $r = eval {sprintf '%v' . chr $ord}; | |
465 | is ($bad, 0, "pattern '%v' . chr $ord"); | |
466 | } | |
467 | } | |
9911cee9 TS |
468 | |
469 | sub mysprintf_int_flags { | |
470 | my ($fmt, $num) = @_; | |
471 | die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/; | |
472 | my $flag = $1; | |
473 | my $width = $2; | |
474 | my $sign = $num < 0 ? '-' : | |
475 | $flag =~ /\+/ ? '+' : | |
476 | $flag =~ /\ / ? ' ' : | |
477 | ''; | |
478 | my $abs = abs($num); | |
479 | my $padlen = $width - length($sign.$abs); | |
480 | return | |
481 | $flag =~ /0/ && $flag !~ /-/ # do zero padding | |
482 | ? $sign . '0' x $padlen . $abs | |
483 | : $flag =~ /-/ # left or right | |
484 | ? $sign . $abs . ' ' x $padlen | |
485 | : ' ' x $padlen . $sign . $abs; | |
486 | } | |
487 | ||
488 | # Whole tests for "%4d" with 2 to 4 flags; | |
489 | # total counts: 3 * (4**2 + 4**3 + 4**4) == 1008 | |
490 | ||
491 | my @flags = ("-", "+", " ", "0"); | |
492 | for my $num (0, -1, 1) { | |
493 | for my $f1 (@flags) { | |
494 | for my $f2 (@flags) { | |
495 | for my $f3 ('', @flags) { # '' for doubled flags | |
496 | my $flag = $f1.$f2.$f3; | |
497 | my $width = 4; | |
498 | my $fmt = '%'."${flag}${width}d"; | |
499 | my $result = sprintf($fmt, $num); | |
500 | my $expect = mysprintf_int_flags($fmt, $num); | |
501 | is($result, $expect, qq/sprintf("$fmt",$num)/); | |
502 | ||
503 | next if $f3 eq ''; | |
504 | ||
505 | for my $f4 (@flags) { # quadrupled flags | |
506 | my $flag = $f1.$f2.$f3.$f4; | |
507 | my $fmt = '%'."${flag}${width}d"; | |
508 | my $result = sprintf($fmt, $num); | |
509 | my $expect = mysprintf_int_flags($fmt, $num); | |
510 | is($result, $expect, qq/sprintf("$fmt",$num)/); | |
511 | } | |
512 | } | |
513 | } | |
514 | } | |
515 | } | |
516 | ||
9c2a5cfe B |
517 | # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] |
518 | foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN | |
519 | eval { my $f = sprintf("%f", $n); }; | |
520 | is $@, "", "sprintf(\"%f\", $n)"; | |
521 | } | |
53f65a9e HS |
522 | |
523 | # test %ll formats with and without HAS_QUAD | |
53f65a9e | 524 | my @tests = ( |
8ff953de MHM |
525 | [ '%lld' => [qw( 4294967296 -100000000000000 )] ], |
526 | [ '%lli' => [qw( 4294967296 -100000000000000 )] ], | |
527 | [ '%llu' => [qw( 4294967296 100000000000000 )] ], | |
528 | [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], | |
529 | [ '%Li' => [qw( 4294967296 -100000000000000 )] ], | |
530 | [ '%Lu' => [qw( 4294967296 100000000000000 )] ], | |
53f65a9e HS |
531 | ); |
532 | ||
533 | for my $t (@tests) { | |
8ff953de MHM |
534 | my($fmt, $nums) = @$t; |
535 | for my $num (@$nums) { | |
826af139 AB |
536 | my $w = ''; |
537 | local $SIG{__WARN__} = sub { $w .= shift }; | |
538 | my $sprintf_got = sprintf($fmt, $num); | |
539 | if ($Q) { | |
540 | is($sprintf_got, $num, "quad: $fmt -> $num"); | |
541 | is($w, '', "no warnings for: $fmt -> $num"); | |
542 | } else { | |
543 | is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt"); | |
544 | like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt"); | |
3101bb05 | 545 | like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt"); |
826af139 | 546 | } |
53f65a9e HS |
547 | } |
548 | } | |
549 | ||
9ef5ed94 AV |
550 | # Check unicode vs byte length |
551 | for my $width (1,2,3,4,5,6,7) { | |
552 | for my $precis (1,2,3,4,5,6,7) { | |
553 | my $v = "\x{20ac}\x{20ac}"; | |
554 | my $format = "%" . $width . "." . $precis . "s"; | |
555 | my $chars = ($precis > 2 ? 2 : $precis); | |
556 | my $space = ($width < 2 ? 0 : $width - $chars); | |
557 | fresh_perl_is( | |
558 | 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', | |
559 | "$space$chars", | |
560 | {}, | |
561 | q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), | |
562 | ); | |
563 | } | |
564 | } | |
667f6f15 FC |
565 | |
566 | # Overload count | |
1d55083c FC |
567 | package o { |
568 | use overload | |
569 | '""', sub { ++our $count; $_[0][0]; }, | |
570 | '0+', sub { ++our $numcount; $_[0][1]; } | |
571 | } | |
572 | my $o = bless ["\x{100}",42], o::; | |
667f6f15 FC |
573 | () = sprintf "%1s", $o; |
574 | is $o::count, '1', 'sprinf %1s overload count'; | |
575 | $o::count = 0; | |
576 | () = sprintf "%.1s", $o; | |
577 | is $o::count, '1', 'sprinf %.1s overload count'; | |
1d55083c FC |
578 | $o::count = 0; |
579 | () = sprintf "%d", $o; | |
580 | is $o::count, 0, 'sprintf %d string overload count is 0'; | |
581 | is $o::numcount, 1, 'sprintf %d number overload count is 1'; | |
40bca5ae | 582 | |
35ff3d7d JH |
583 | my $ppc_linux = $Config{archname} =~ /^(?:ppc|power(?:pc)?)(?:64)?-linux/; |
584 | my $irix_ld = $Config{archname} =~ /^IP\d+-irix-ld$/; | |
261d007a | 585 | |
40bca5ae JH |
586 | for my $t (@hexfloat) { |
587 | my ($format, $arg, $expected) = @$t; | |
588 | $arg = eval $arg; | |
589 | my $result = sprintf($format, $arg); | |
61b5c618 | 590 | my $ok = $result eq $expected; |
35ff3d7d JH |
591 | # For certain platforms (all of which are currently double-double, |
592 | # but different implementations, GNU vs vendor, two different archs | |
593 | # (ppc and mips), and two different libm interfaces) we have some | |
594 | # bits-in-the-last-hexdigit differences. | |
595 | # Patch them up as TODOs instead of deadly errors. | |
596 | if ($doubledouble && $ppc_linux && $arg =~ /^2.71828/) { | |
597 | # gets '0x1.5bf0a8b1457695355fb8ac404ecp+1' | |
598 | # wants '0x1.5bf0a8b1457695355fb8ac404e8p+1' | |
261d007a JH |
599 | local $::TODO = "$Config{archname} exp(1)"; |
600 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); | |
601 | next; | |
602 | } | |
ced634a4 | 603 | if ($doubledouble && $irix_ld && $arg =~ /^1.41421/) { |
ced634a4 JH |
604 | # gets '0x1.6a09e667f3bcc908b2fb1366eacp+0' |
605 | # wants '0x1.6a09e667f3bcc908b2fb1366ea8p+0' | |
606 | local $::TODO = "$Config{archname} sqrt(2)"; | |
607 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); | |
608 | next; | |
609 | } | |
61b5c618 JH |
610 | unless ($ok) { |
611 | # It seems that there can be difference in the last bits: | |
612 | # [perl #122578] | |
613 | # got "0x1.5bf0a8b14576ap+1" | |
614 | # expected "0x1.5bf0a8b145769p+1" | |
615 | # (Android on ARM) | |
616 | # | |
617 | # Exact cause unknown but suspecting different fp rounding modes, | |
618 | # (towards zero? towards +inf? towards -inf?) about which Perl | |
619 | # is blissfully unaware. | |
620 | # | |
621 | # Try extracting one (or sometimes two) last mantissa | |
622 | # hexdigits, and see if they differ in value by one. | |
623 | my ($rh, $eh) = ($result, $expected); | |
624 | sub extract_prefix { | |
13d235b3 | 625 | ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1; |
61b5c618 JH |
626 | } |
627 | my $rp = extract_prefix($rh); | |
628 | my $ep = extract_prefix($eh); | |
629 | print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n"; | |
630 | if ($rp eq $ep) { # If prefixes match. | |
631 | sub extract_exponent { | |
13d235b3 | 632 | ($_[0] =~ s/([pP][+-]?\d+)//) && return $1; |
61b5c618 JH |
633 | } |
634 | my $re = extract_exponent($rh); | |
635 | my $ee = extract_exponent($eh); | |
636 | print "# re = $re, ee = $ee (rh $rh, eh $eh)\n"; | |
637 | if ($re eq $ee) { # If exponents match. | |
638 | # Remove the common prefix of the mantissa bits. | |
639 | my $la = length($rh); | |
640 | my $lb = length($eh); | |
641 | my $i; | |
642 | for ($i = 0; $i < $la && $i < $lb; $i++) { | |
643 | last if substr($rh, $i, 1) ne substr($eh, $i, 1); | |
644 | } | |
645 | $rh = substr($rh, $i); | |
646 | $eh = substr($eh, $i); | |
647 | print "# (rh $rh, eh $eh)\n"; | |
648 | if ($rh ne $eh) { | |
649 | # If necessary, pad the shorter one on the right | |
650 | # with one zero (for example "...1f" vs "...2", | |
651 | # we want to compare "1f" to "20"). | |
652 | if (length $rh < length $eh) { | |
653 | $rh .= '0'; | |
654 | } elsif (length $eh < length $rh) { | |
655 | $eh .= '0'; | |
656 | } | |
657 | print "# (rh $rh, eh $eh)\n"; | |
658 | if (length $eh == length $rh) { | |
659 | if (abs(hex($eh) - hex($rh)) == 1) { | |
660 | $ok = 1; | |
661 | } | |
662 | } | |
663 | } | |
664 | } | |
665 | } | |
666 | } | |
667 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); | |
40bca5ae | 668 | } |
5488d373 S |
669 | |
670 | # double-double long double %a special testing. | |
671 | SKIP: { | |
0b367b79 CB |
672 | skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef') |
673 | . " longdblkind=$Config{longdblkind} os=$^O", 6) | |
796fb084 JH |
674 | unless ($Config{uselongdouble} && |
675 | ($Config{longdblkind} == 5 || | |
676 | $Config{longdblkind} == 6) | |
1c273873 JH |
677 | # Gating on 'linux' (ppc) here is due to the differing |
678 | # double-double implementations: other (also big-endian) | |
679 | # double-double platforms (e.g. AIX on ppc or IRIX on mips) | |
680 | # do not behave similarly. | |
796fb084 JH |
681 | && $^O eq 'linux' |
682 | ); | |
5488d373 S |
683 | # [rt.perl.org 125633] |
684 | like(sprintf("%La\n", (2**1020) + (2**-1072)), | |
685 | qr/^0x1.0{522}1p\+1020$/); | |
686 | like(sprintf("%La\n", (2**1021) + (2**-1072)), | |
687 | qr/^0x1.0{523}8p\+1021$/); | |
688 | like(sprintf("%La\n", (2**1022) + (2**-1072)), | |
689 | qr/^0x1.0{523}4p\+1022$/); | |
690 | like(sprintf("%La\n", (2**1023) + (2**-1072)), | |
691 | qr/^0x1.0{523}2p\+1023$/); | |
692 | like(sprintf("%La\n", (2**1023) + (2**-1073)), | |
693 | qr/^0x1.0{523}1p\+1023$/); | |
694 | like(sprintf("%La\n", (2**1023) + (2**-1074)), | |
695 | qr/^0x1.0{524}8p\+1023$/); | |
696 | } | |
4755cf01 JH |
697 | |
698 | SKIP: { | |
798a7a50 | 699 | skip("negative zero not available\n", 3) |
4755cf01 JH |
700 | unless sprintf('%+f', -0.0) =~ /^-0/; |
701 | is(sprintf("%a", -0.0), "-0x0p+0", "negative zero"); | |
702 | is(sprintf("%+a", -0.0), "-0x0p+0", "negative zero"); | |
798a7a50 | 703 | is(sprintf("%.13a", -0.0), "-0x0.0000000000000p+0", "negative zero"); |
4755cf01 | 704 | } |
eba98284 JH |
705 | |
706 | SKIP: { | |
707 | # [perl #127183] Non-canonical hexadecimal floats are parsed prematurely | |
708 | ||
709 | skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53", 3) | |
710 | unless $Config{nv_preserves_uv_bits} == 53; | |
711 | ||
712 | { | |
713 | # The 0x0.b17217f7d1cf78p0 is the original LHS value | |
714 | # from [perl #127183], its bits are 0x162e42fefa39ef << 3, | |
715 | # resulting in a non-canonical form of hexfp, where the most | |
716 | # significant bit is zero, instead of one. | |
717 | is(sprintf("%a", 0x0.b17217f7d1cf78p0 - 0x1.62e42fefa39efp-1), | |
718 | "0x0p+0", | |
719 | "non-canonical form [perl #127183]"); | |
720 | } | |
721 | ||
722 | { | |
723 | no warnings 'overflow'; # Not the point here. | |
724 | ||
725 | # The 0x058b90bfbe8e7bc is 0x162e42fefa39ef << 2, | |
726 | # the 0x02c5c85fdf473de is 0x162e42fefa39ef << 1, | |
727 | # see above. | |
728 | is(sprintf("%a", 0x0.58b90bfbe8e7bcp1 - 0x1.62e42fefa39efp-1), | |
729 | "0x0p+0", | |
730 | "non-canonical form"); | |
731 | ||
732 | is(sprintf("%a", 0x0.2c5c85fdf473dep2 - 0x1.62e42fefa39efp-1), | |
733 | "0x0p+0", | |
734 | "non-canonical form"); | |
735 | } | |
736 | } |