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