This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sprintf(): add memory wrap tests
[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
fc7325bb 298# Used to mangle PL_sv_undef
7baa4690 299fresh_perl_like(
fc7325bb 300 'print sprintf "xxx%n\n"; print undef',
624c42e2 301 qr/Modification of a read-only value attempted at\b/,
fc7325bb
GA
302 { switches => [ '-w' ] },
303 q(%n should not be able to modify read-only constants),
863811b2
DM
304);
305
2fba7546 306# check overflows
45e52d63 307for (int(~0/2+1), ~0, "9999999999999999999") {
2fba7546
GA
308 is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d");
309 like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf");
310 is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d");
94bbb3f4 311 like($@, qr/^Integer overflow in format string for printf /, "overflow in printf");
2fba7546 312}
863811b2 313
2fba7546 314# check %NNN$ for range bounds
863811b2
DM
315{
316 my ($warn, $bad) = (0,0);
317 local $SIG{__WARN__} = sub {
7baa4690 318 if ($_[0] =~ /missing argument/i) {
863811b2
DM
319 $warn++
320 }
321 else {
322 $bad++
323 }
324 };
2fba7546 325
45e52d63 326 my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20));
2fba7546
GA
327 my $result = sprintf $fmt, qw(a b c d);
328 is($result, "abcd", "only four valid values in $fmt");
863811b2
DM
329 is($warn, 36, "expected warnings");
330 is($bad, 0, "unexpected warnings");
331}
332
4077a6bc
AB
333# Tests for "missing argument" and "redundant argument" warnings
334{
335 my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
336 local $SIG{__WARN__} = sub {
337 if ($_[0] =~ /missing argument/i) {
338 $warn_missing++
339 }
340 elsif ($_[0] =~ /redundant argument/i) {
341 $warn_redundant++
342 }
343 else {
344 $warn_bad++
345 }
346 };
347
348 my @tests = (
349 # The "", "%s", and "%-p" formats have special-case handling
350 # in sv.c
351 {
352 fmt => "",
353 args => [ qw( x ) ],
354 res => "",
355 m => 0,
356 r => 1,
357 },
358 {
359 fmt => "%s",
360 args => [ qw( x y ) ],
361 res => "x",
362 m => 0,
363 r => 1,
364 },
365 {
366 fmt => "%-p",
367 args => [ qw( x y ) ],
368 res => qr/^[0-9a-f]+$/as,
369 m => 0,
370 r => 1,
371 },
372 # Other non-specialcased patterns
373 {
374 fmt => "%s : %s",
375 args => [ qw( a b c ) ],
376 res => "a : b",
377 m => 0,
378 r => 1,
379 },
380 {
381 fmt => "%s : %s : %s",
382 args => [ qw( a b c d e ) ],
383 res => "a : b : c",
384 m => 0,
385 # Note how we'll only warn about redundant arguments once,
386 # even though both "d" and "e" are redundant...
387 r => 1,
388 },
389 {
390 fmt => "%s : %s : %s",
391 args => [ ],
392 res => " : : ",
393 # ...But when arguments are missing we'll warn about every
394 # missing argument. This difference between the two
395 # warnings is a feature.
396 m => 3,
397 r => 0,
398 },
399
400 # Tests for format parameter indexes.
401 #
402 # Deciding what to do about these is a bit tricky, and so is
403 # "correctly" warning about missing arguments on them.
404 #
405 # Should we warn if you supply 4 arguments but only use
406 # argument 1,3 & 4? Or only if you supply 5 arguments and your
407 # highest used argument is 4?
408 #
409 # For some uses of this printf feature (e.g. i18n systems)
410 # it's a always a logic error to not print out every provided
411 # argument, but for some other uses skipping some might be a
412 # feature (although you could argue that then printf should be
413 # called as e.g:
414 #
415 # printf q[%1$s %3$s], x(), undef, z();
416 #
417 # Instead of:
418 #
419 # printf q[%1$s %3$s], x(), y(), z();
420 #
421 # Since calling the (possibly expensive) y() function is
422 # completely redundant there.
423 #
424 # We deal with all these potential problems by not even
425 # trying. If the pattern contains any format parameter indexes
426 # whatsoever we'll never warn about redundant arguments.
427 {
428 fmt => '%1$s : %2$s',
429 args => [ qw( x y z ) ],
430 res => "x : y",
431 m => 0,
432 r => 0,
433 },
434 {
435 fmt => '%2$s : %4$s : %5$s',
436 args => [ qw( a b c d )],
437 res => "b : d : ",
438 m => 1,
439 r => 0,
440 },
441 {
442 fmt => '%s : %1$s : %s',
443 args => [ qw( x y z ) ],
444 res => "x : x : y",
445 m => 0,
446 r => 0,
447 },
448
449 );
450
451 for my $i (0..$#tests) {
452 my $test = $tests[$i];
453 my $result = sprintf $test->{fmt}, @{$test->{args}};
454
455 my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'";
456 if (ref $test->{res} eq 'Regexp') {
457 like($result, $test->{res}, "$prefix got the right result");
458 } else {
459 is($result, $test->{res}, "$prefix got the right result");
460 }
461 is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings");
462 is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings");
463 is($warn_bad, 0, "$prefix No unknown warnings");
464
465 ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
466 }
467}
468
343ef749
NC
469{
470 foreach my $ord (0 .. 255) {
471 my $bad = 0;
472 local $SIG{__WARN__} = sub {
473 if ($_[0] !~ /^Invalid conversion in sprintf/) {
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");
3101bb05 562 like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf 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
919
920{
921 my $s = 8 * $Config{sizesize};
922 my $i = 1;
923 my $max;
924 while ($s--) { $max |= $i; $i <<= 1; }
925 my $max40 = $max - 40; # see the magic fudge factor in sv_vcatpvfn_flags()
926
927 my @tests = (
928 # format, arg
929 ["%.${max}a", 1.1 ],
930 ["%.${max40}a", 1.1 ],
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; };
938 like("$@", qr/panic: memory wrap/, qq{memory wrap: "$fmt", "$arg"});
939 }
940}
941
942
e3f7a67e 943done_testing();