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