This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/op/sprintf2.t: Generalize test to work on EBCDIC
[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.
811 my $s = sprintf($t->[1], eval $t->[0]);
b6d9b423
JH
812 is($s, $t->[2], "subnormal @$t got $s");
813 }
82229f9f 814
749d8534
JH
815 # [rt.perl.org #128888]
816 is(sprintf("%a", 1.03125), "0x1.08p+0");
817 is(sprintf("%.1a", 1.03125), "0x1.0p+0");
818 is(sprintf("%.0a", 1.03125), "0x1p+0", "[rt.perl.org #128888]");
819
e3f7a67e
JH
820 # [rt.perl.org #128889]
821 is(sprintf("%.*a", -1, 1.03125), "0x1.08p+0", "[rt.perl.org #128889]");
822
823 # [rt.perl.org #128890]
824 is(sprintf("%a", 0x1.18p+0), "0x1.18p+0");
825 is(sprintf("%.1a", 0x1.08p+0), "0x1.0p+0");
826 is(sprintf("%.1a", 0x1.18p+0), "0x1.2p+0", "[rt.perl.org #128890]");
827 is(sprintf("%.1a", 0x1.28p+0), "0x1.2p+0");
828 is(sprintf("%.1a", 0x1.38p+0), "0x1.4p+0");
829 is(sprintf("%.1a", 0x1.48p+0), "0x1.4p+0");
830 is(sprintf("%.1a", 0x1.58p+0), "0x1.6p+0");
831 is(sprintf("%.1a", 0x1.68p+0), "0x1.6p+0");
832 is(sprintf("%.1a", 0x1.78p+0), "0x1.8p+0");
833 is(sprintf("%.1a", 0x1.88p+0), "0x1.8p+0");
834 is(sprintf("%.1a", 0x1.98p+0), "0x1.ap+0");
835 is(sprintf("%.1a", 0x1.a8p+0), "0x1.ap+0");
836 is(sprintf("%.1a", 0x1.b8p+0), "0x1.cp+0");
837 is(sprintf("%.1a", 0x1.c8p+0), "0x1.cp+0");
838 is(sprintf("%.1a", 0x1.d8p+0), "0x1.ep+0");
839 is(sprintf("%.1a", 0x1.e8p+0), "0x1.ep+0");
840 is(sprintf("%.1a", 0x1.f8p+0), "0x2.0p+0");
841
842 is(sprintf("%.1a", 0x1.10p+0), "0x1.1p+0");
843 is(sprintf("%.1a", 0x1.17p+0), "0x1.1p+0");
844 is(sprintf("%.1a", 0x1.19p+0), "0x1.2p+0");
845 is(sprintf("%.1a", 0x1.1fp+0), "0x1.2p+0");
846
847 is(sprintf("%.2a", 0x1.fffp+0), "0x2.00p+0");
848 is(sprintf("%.2a", 0xf.fffp+0), "0x2.00p+3");
849
850 # [rt.perl.org #128893]
851 is(sprintf("%020a", 1.5), "0x0000000000001.8p+0");
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("% 020a", 1.5), " 0x000000000001.8p+0", "[rt.perl.org #128893]");
855 is(sprintf("%20a", -1.5), " -0x1.8p+0");
856 is(sprintf("%+20a", 1.5), " +0x1.8p+0");
857 is(sprintf("% 20a", 1.5), " 0x1.8p+0");
749d8534 858}
e3f7a67e
JH
859
860# x86 80-bit long-double tests for
ee58923a 861# rt.perl.org #128843, #128888, #128889, #128890, #128893, #128909
e3f7a67e 862SKIP: {
f40ac91c 863 skip("non-80-bit-long-double", 17)
e3f7a67e
JH
864 unless ($Config{uselongdouble} &&
865 ($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
85272d31 866 ($Config{long_double_style_ieee_extended}));
e3f7a67e 867
f40ac91c
JH
868 {
869 # The last normal for this format.
870 is(sprintf("%a", eval '0x1p-16382'), "0x8p-16385", "[rt.perl.org #128843]");
871
872 # The subnormals cause "exponent underflow" warnings,
873 # but that is not why we are here.
874 local $SIG{__WARN__} = sub {
875 die "$0: $_[0]" unless $_[0] =~ /exponent underflow/;
876 };
877
878 is(sprintf("%a", eval '0x1p-16383'), "0x4p-16382", "[rt.perl.org #128843]");
879 is(sprintf("%a", eval '0x1p-16384'), "0x2p-16382", "[rt.perl.org #128843]");
880 is(sprintf("%a", eval '0x1p-16385'), "0x1p-16382", "[rt.perl.org #128843]");
881 is(sprintf("%a", eval '0x1p-16386'), "0x8p-16386", "[rt.perl.org #128843]");
882 is(sprintf("%a", eval '0x1p-16387'), "0x4p-16386", "[rt.perl.org #128843]");
883 }
e3f7a67e
JH
884 is(sprintf("%.0a", 1.03125), "0x8p-3", "[rt.perl.org #128888]");
885 is(sprintf("%.*a", -1, 1.03125), "0x8.4p-3", "[rt.perl.org #128889]");
886 is(sprintf("%.1a", 0x8.18p+0), "0x8.2p+0", "[rt.perl.org #128890]");
887 is(sprintf("%020a", -1.5), "-0x0000000000000cp-3", "[rt.perl.org #128893]");
888 is(sprintf("%+020a", 1.5), "+0x0000000000000cp-3", "[rt.perl.org #128893]");
889 is(sprintf("% 020a", 1.5), " 0x0000000000000cp-3", "[rt.perl.org #128893]");
ee58923a
JH
890 is(sprintf("%a", 1.9999999999999999999), "0xf.fffffffffffffffp-3");
891 is(sprintf("%.3a", 1.9999999999999999999), "0x1.000p+1", "[rt.perl.org #128909]");
892 is(sprintf("%.2a", 1.9999999999999999999), "0x1.00p+1");
893 is(sprintf("%.1a", 1.9999999999999999999), "0x1.0p+1");
894 is(sprintf("%.0a", 1.9999999999999999999), "0x1p+1");
e3f7a67e
JH
895}
896
de1a8b53
JH
897# quadmath tests for rt.perl.org #128843
898SKIP: {
899 skip "need quadmath", 7, unless $Config{usequadmath};
900
901 is(sprintf("%a", eval '0x1p-16382'), '0x1p-16382'); # last normal
902
903 local $SIG{__WARN__} = sub {
904 die "$0: $_[0]" unless $_[0] =~ /exponent underflow/;
905 };
906
907 is(sprintf("%a", eval '0x1p-16383'), '0x1p-16383');
908 is(sprintf("%a", eval '0x1p-16384'), '0x1p-16384');
909
910 is(sprintf("%a", eval '0x1p-16491'), '0x1p-16491');
911 is(sprintf("%a", eval '0x1p-16492'), '0x1p-16492');
912 is(sprintf("%a", eval '0x1p-16493'), '0x1p-16493'); # last denormal
913
914 is(sprintf("%a", eval '0x1p-16494'), '0x1p-16494'); # underflow
915}
916
d729f63c
DM
917# check all calls to croak_memory_wrap()
918# RT #131260
1cf776ef
DM
919# (these now fail earlier with "Integer overflow" rather than
920# "memory wrap" - DAPM)
d729f63c
DM
921
922{
923 my $s = 8 * $Config{sizesize};
924 my $i = 1;
925 my $max;
926 while ($s--) { $max |= $i; $i <<= 1; }
d729f63c
DM
927
928 my @tests = (
929 # format, arg
930 ["%.${max}a", 1.1 ],
d729f63c
DM
931 ["%.${max}i", 1 ],
932 ["%.${max}i", -1 ],
933 );
934
935 for my $test (@tests) {
936 my ($fmt, $arg) = @$test;
937 eval { my $s = sprintf $fmt, $arg; };
1cf776ef
DM
938 like("$@", qr/Integer overflow in format string/,
939 qq{Integer overflow: "$fmt", "$arg"});
d729f63c
DM
940 }
941}
942
c0535913
DM
943{
944 # handle utf8 correctly when skipping invalid format
945 my $w_red = 0;
946 my $w_inv = 0;
947 my $w_other = 0;
948 local $SIG{__WARN__} = sub {
949 if ($_[0] =~ /^Invalid conversion/) {
950 $w_inv++;
951 }
952 elsif ($_[0] =~ /^Redundant argument/) {
953 $w_red++;
954 }
955 else {
956 $w_other++;
957 }
958 };
959
960 use warnings;
ceea523d
KW
961 my $cap_A_macron_utf8 = byte_utf8a_to_utf8n("\xc4\x80");
962 my $small_a_breve_utf8 = byte_utf8a_to_utf8n("\xc4\x83");
963 my $s = sprintf "%s%$cap_A_macron_utf8%s",
964 "\x{102}",
965 $small_a_breve_utf8;
966 is($s, "\x{102}%$cap_A_macron_utf8$small_a_breve_utf8",
967 "utf8 for invalid format");
c0535913
DM
968 is($w_inv, 1, "utf8 for invalid format: invalid warnings");
969 is($w_red, 0, "utf8 for invalid format: redundant warnings");
970 is($w_other, 0, "utf8 for invalid format: other warnings");
971}
d729f63c 972
9cc0d839
DM
973# it used to upgrade the result to utf8 if the 1st arg happened to be utf8
974
975{
976 my $precis = "9";
977 utf8::upgrade($precis);
978 my $s = sprintf "%.*f\n", $precis, 1.1;
979 ok(!utf8::is_utf8($s), "first arg not special utf8-wise");
980}
981
0ea23158
DM
982# sprintf("%n") used to croak "Modification of a read-only value"
983# as it tried to set &PL_sv_no
984
985{
986 eval { my $s = sprintf("%n"); };
987 like $@, qr/Missing argument for %n in sprintf/, "%n";
988}
9cc0d839 989
84a826ef
DM
990# %p of an Inf or Nan address should still print its address, not
991# 'Inf' etc.
992
993like sprintf("%p", 0+'Inf'), qr/^[0-9a-f]+$/, "%p and Inf";
994like sprintf("%p", 0+'NaN'), qr/^[0-9a-f]+$/, "%p and NaN";
995
50a72221 996# when the width or precision is specified by an argument, handle overflows
1cf776ef 997# ditto for literal precisions.
50a72221
DM
998
999{
1000 for my $i (
1001 (~0 ) - 0, # UV_MAX
1002 (~0 ) - 1,
1003 (~0 ) - 2,
1004
1005 (~0 >> 1) + 2,
1006 (~0 >> 1) + 1,
1007 (~0 >> 1) - 0, # IV_MAX
1008 (~0 >> 1) - 1,
1009 (~0 >> 1) - 2,
1010
1011 (~0 >> 2) + 2,
1012 (~0 >> 2) + 1,
1013
1014 -1 - (~0 >> 1),# -(IV_MAX+1)
1015 0 - (~0 >> 1),
1016 1 - (~0 >> 1),
1017
1018 -2 - (~0 >> 2),
1019 -1 - (~0 >> 2),
1020 )
1021 {
1022 my $hex = sprintf "0x%x", $i;
1023 eval { my $s = sprintf '%*s', $i, "abc"; };
1024 like $@, qr/Integer overflow/, "overflow: %*s $hex, $i";
1cf776ef 1025
50a72221
DM
1026 eval { my $s = sprintf '%*2$s', "abc", $i; };
1027 like $@, qr/Integer overflow/, 'overflow: %*2$s';
1cf776ef 1028
50a72221
DM
1029 eval { my $s = sprintf '%.*s', $i, "abc"; };
1030 like $@, qr/Integer overflow/, 'overflow: %.*s';
1cf776ef 1031
50a72221
DM
1032 eval { my $s = sprintf '%.*2$s', "abc", $i; };
1033 like $@, qr/Integer overflow/, 'overflow: %.*2$s';
1cf776ef
DM
1034
1035 next if $i < 0;
1036
1037 eval { my $s = sprintf "%.${i}f", 1.234 };
1038 like $@, qr/Integer overflow/, 'overflow: %.NNNf';
50a72221
DM
1039 }
1040}
1041
1042
e3f7a67e 1043done_testing();