This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix on top of 75326c48.
[perl5.git] / t / op / sprintf2.t
1 #!./perl -w
2
3 # Tests for sprintf that do not fit the format of sprintf.t.
4
5 BEGIN {
6     chdir 't' if -d 't';
7     @INC = '../lib';
8     require './test.pl';
9 }   
10
11 # We'll run 12 extra tests (see below) if $Q is false.
12 eval { my $q = pack "q", 0 };
13 my $Q = $@ eq '';
14
15 my $doubledouble;
16
17 # %a and %A depend on the floating point config
18 # This totally doesn't test non-IEEE-754 float formats.
19 my @hexfloat;
20 print "# uvsize = $Config{uvsize}\n";
21 print "# nvsize = $Config{nvsize}\n";
22 print "# nv_preserves_uv_bits = $Config{nv_preserves_uv_bits}\n";
23 print "# d_quad = $Config{d_quad}\n";
24 if ($Config{nvsize} == 8 &&
25     (
26      # IEEE-754 64-bit ("double precision"), the most common out there
27      ($Config{uvsize} == 8 && $Config{nv_preserves_uv_bits} == 53)
28      ||
29      # If we have a quad we can still get the mantissa bits.
30      ($Config{uvsize} == 4 && $Config{d_quad})
31      )
32     ) {
33     @hexfloat = (
34         [ '%a',       '0',       '0x0p+0' ],
35         [ '%a',       '1',       '0x1p+0' ],
36         [ '%a',       '1.0',     '0x1p+0' ],
37         [ '%a',       '0.5',     '0x1p-1' ],
38         [ '%a',       '0.25',    '0x1p-2' ],
39         [ '%a',       '0.75',    '0x1.8p-1' ],
40         [ '%a',       '3.14',    '0x1.91eb851eb851fp+1' ],
41         [ '%a',       '-1.0',    '-0x1p+0' ],
42         [ '%a',       '-3.14',   '-0x1.91eb851eb851fp+1' ],
43         [ '%a',       '0.1',     '0x1.999999999999ap-4' ],
44         [ '%a',       '1/7',     '0x1.2492492492492p-3' ],
45         [ '%a',       'sqrt(2)', '0x1.6a09e667f3bcdp+0' ],
46         [ '%a',       'exp(1)',  '0x1.5bf0a8b145769p+1' ],
47         [ '%a',       '2**-10',  '0x1p-10' ],
48         [ '%a',       '2**10',   '0x1p+10' ],
49         [ '%a',       '1e-9',    '0x1.12e0be826d695p-30' ],
50         [ '%a',       '1e9',     '0x1.dcd65p+29' ],
51
52         [ '%#a',      '1',       '0x1.p+0' ],
53         [ '%+a',      '1',       '+0x1p+0' ],
54         [ '%+a',      '-1',      '-0x1p+0' ],
55         [ '% a',      ' 1',      ' 0x1p+0' ],
56         [ '% a',      '-1',      '-0x1p+0' ],
57
58         [ '%+ a',     '1',       '+0x1p+0' ],
59         [ '%+ a',     '-1',      '-0x1p+0' ],
60         [ '% +a',     ' 1',      '+0x1p+0' ],
61         [ '% +a',     '-1',      '-0x1p+0' ],
62
63         [ '%8a',      '3.14',   '0x1.91eb851eb851fp+1' ],
64         [ '%13a',     '3.14',   '0x1.91eb851eb851fp+1' ],
65         [ '%20a',     '3.14',   '0x1.91eb851eb851fp+1' ],
66         [ '%.4a',     '3.14',   '0x1.91ecp+1' ],
67         [ '%.5a',     '3.14',   '0x1.91eb8p+1' ],
68         [ '%.6a',     '3.14',   '0x1.91eb85p+1' ],
69         [ '%.20a',    '3.14',   '0x1.91eb851eb851f0000000p+1' ],
70         [ '%20.10a',  '3.14',   '   0x1.91eb851eb8p+1' ],
71         [ '%20.15a',  '3.14',   '0x1.91eb851eb851f00p+1' ],
72         [ '% 20.10a', '3.14',   '   0x1.91eb851eb8p+1' ],
73         [ '%020.10a', '3.14',   '0x0001.91eb851eb8p+1' ],
74
75         [ '%.13a',    '1',   '0x1.0000000000000p+0' ],
76         [ '%.13a',    '-1',  '-0x1.0000000000000p+0' ],
77         [ '%.13a',    '0',   '0x0.0000000000000p+0' ],
78
79         [ '%30a',  '3.14',   '          0x1.91eb851eb851fp+1' ],
80         [ '%-30a', '3.14',   '0x1.91eb851eb851fp+1          ' ],
81         [ '%030a',  '3.14',  '0x00000000001.91eb851eb851fp+1' ],
82         [ '%-030a', '3.14',  '0x1.91eb851eb851fp+1          ' ],
83
84         [ '%.40a',  '3.14',
85           '0x1.91eb851eb851f000000000000000000000000000p+1' ],
86
87         [ '%A',       '3.14',   '0X1.91EB851EB851FP+1' ],
88         );
89 } elsif (($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
90          # 80-bit ("extended precision") long double, pack F is the NV
91          # cd cc cc cc cc cc cc cc fb bf 00 00 00 00 00 00
92          # cd cc cc cc cc cc cc cc fb bf 00 00
93          (pack("F", 0.1) =~ /^\xCD/ ||  # LE
94           pack("F", 0.1) =~ /\xCD$/)) { # BE (if this ever happens)
95     @hexfloat = (
96         [ '%a',       '0',       '0x0p+0' ],
97         [ '%a',       '1',       '0x8p-3' ],
98         [ '%a',       '1.0',     '0x8p-3' ],
99         [ '%a',       '0.5',     '0x8p-4' ],
100         [ '%a',       '0.25',    '0x8p-5' ],
101         [ '%a',       '0.75',    '0xcp-4' ],
102         [ '%a',       '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
103         [ '%a',       '-1.0',    '-0x8p-3' ],
104         [ '%a',       '-3.14',   '-0xc.8f5c28f5c28f5c3p-2' ],
105         [ '%a',       '0.1',     '0xc.ccccccccccccccdp-7' ],
106         [ '%a',       '1/7',     '0x9.249249249249249p-6' ],
107         [ '%a',       'sqrt(2)', '0xb.504f333f9de6484p-3' ],
108         [ '%a',       'exp(1)',  '0xa.df85458a2bb4a9bp-2' ],
109         [ '%a',       '2**-10',  '0x8p-13' ],
110         [ '%a',       '2**10',   '0x8p+7' ],
111         [ '%a',       '1e-9',    '0x8.9705f4136b4a597p-33' ],
112         [ '%a',       '1e9',     '0xe.e6b28p+26' ],
113
114         [ '%#a',      '1',       '0x8.p-3' ],
115         [ '%+a',      '1',       '+0x8p-3' ],
116         [ '%+a',      '-1',      '-0x8p-3' ],
117         [ '% a',      ' 1',      ' 0x8p-3' ],
118         [ '% a',      '-1',      '-0x8p-3' ],
119
120         [ '%+ a',     '1',       '+0x8p-3' ],
121         [ '%+ a',     '-1',      '-0x8p-3' ],
122         [ '% +a',     ' 1',      '+0x8p-3' ],
123         [ '% +a',     '-1',      '-0x8p-3' ],
124
125         [ '%8a',      '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
126         [ '%13a',     '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
127         [ '%20a',     '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
128         [ '%.4a',     '3.14',    '0xc.8f5cp-2' ],
129         [ '%.5a',     '3.14',    '0xc.8f5c3p-2' ],
130         [ '%.6a',     '3.14',    '0xc.8f5c29p-2' ],
131         [ '%.20a',    '3.14',    '0xc.8f5c28f5c28f5c300000p-2' ],
132         [ '%20.10a',  '3.14',    '   0xc.8f5c28f5c3p-2' ],
133         [ '%20.15a',  '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
134         [ '% 20.10a', '3.14',    '   0xc.8f5c28f5c3p-2' ],
135         [ '%020.10a', '3.14',    '0x000c.8f5c28f5c3p-2' ],
136
137         [ '%30a',  '3.14',   '        0xc.8f5c28f5c28f5c3p-2' ],
138         [ '%-30a', '3.14',   '0xc.8f5c28f5c28f5c3p-2        ' ],
139         [ '%030a',  '3.14',  '0x00000000c.8f5c28f5c28f5c3p-2' ],
140         [ '%-030a', '3.14',  '0xc.8f5c28f5c28f5c3p-2        ' ],
141
142         [ '%.40a',  '3.14',
143           '0xc.8f5c28f5c28f5c30000000000000000000000000p-2' ],
144
145         [ '%A',       '3.14',    '0XC.8F5C28F5C28F5C3P-2' ],
146         );
147 } elsif (
148     # IEEE 754 128-bit ("quadruple precision"), e.g. IA-64 (Itanium) in VMS
149     $Config{nvsize} == 16 &&
150     # 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f (LE), pack F is the NV
151     (pack("F", 0.1) =~ /^\x9A\x99{6}/ ||  # LE
152      pack("F", 0.1) =~ /\x99{6}\x9A$/)    # BE
153     ) {
154     @hexfloat = (
155         [ '%a', '0',       '0x0p+0' ],
156         [ '%a', '1',       '0x1p+0' ],
157         [ '%a', '1.0',     '0x1p+0' ],
158         [ '%a', '0.5',     '0x1p-1' ],
159         [ '%a', '0.25',    '0x1p-2' ],
160         [ '%a', '0.75',    '0x1.8p-1' ],
161         [ '%a', '3.14',    '0x1.91eb851eb851eb851eb851eb851fp+1' ],
162         [ '%a', '-1',      '-0x1p+0' ],
163         [ '%a', '-3.14',   '-0x1.91eb851eb851eb851eb851eb851fp+1' ],
164         [ '%a', '0.1',     '0x1.999999999999999999999999999ap-4' ],
165         [ '%a', '1/7',     '0x1.2492492492492492492492492492p-3' ],
166         [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea95p+0' ],
167         [ '%a', 'exp(1)',  '0x1.5bf0a8b1457695355fb8ac404e7ap+1' ],
168         [ '%a', '2**-10',  '0x1p-10' ],
169         [ '%a', '2**10',   '0x1p+10' ],
170         [ '%a', '1e-09',   '0x1.12e0be826d694b2e62d01511f12ap-30' ],
171         [ '%a', '1e9',     '0x1.dcd65p+29' ],
172
173         [ '%#a', '1',      '0x1.p+0' ],
174         [ '%+a', '1',      '+0x1p+0' ],
175         [ '%+a', '-1',     '-0x1p+0' ],
176         [ '% a', '1',      ' 0x1p+0' ],
177         [ '% a', '-1',     '-0x1p+0' ],
178
179         [ '%+ a', '1',     '+0x1p+0' ],
180         [ '%+ a', '-1',    '-0x1p+0' ],
181         [ '% +a', ' 1',    '+0x1p+0' ],
182         [ '% +a', '-1',    '-0x1p+0' ],
183
184         [ '%8a',      '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ],
185         [ '%13a',     '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ],
186         [ '%20a',     '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ],
187         [ '%.4a',     '3.14', '0x1.91ecp+1' ],
188         [ '%.5a',     '3.14', '0x1.91eb8p+1' ],
189         [ '%.6a',     '3.14', '0x1.91eb85p+1' ],
190         [ '%.20a',    '3.14', '0x1.91eb851eb851eb851eb8p+1' ],
191         [ '%20.10a',  '3.14', '   0x1.91eb851eb8p+1' ],
192         [ '%20.15a',  '3.14', '0x1.91eb851eb851eb8p+1' ],
193         [ '% 20.10a', '3.14', '   0x1.91eb851eb8p+1' ],
194         [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ],
195
196         [ '%30a',     '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ],
197         [ '%-30a',    '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ],
198         [ '%030a',    '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ],
199         [ '%-030a',   '3.14', '0x1.91eb851eb851eb851eb851eb851fp+1' ],
200
201         [ '%.40a',  '3.14',
202           '0x1.91eb851eb851eb851eb851eb851f000000000000p+1' ],
203
204         [ '%A',       '3.14', '0X1.91EB851EB851EB851EB851EB851FP+1' ],
205         );
206 } elsif (
207     # "double-double", two 64-bit doubles end to end
208     $Config{nvsize} == 16 &&
209     # bf b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE), pack F is the NV
210     (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ ||  # LE
211      pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/)    # BE
212     ) {
213     $doubledouble = 1;
214     @hexfloat = (
215         [ '%a', '0',       '0x0p+0' ],
216         [ '%a', '1',       '0x1p+0' ],
217         [ '%a', '1.0',     '0x1p+0' ],
218         [ '%a', '0.5',     '0x1p-1' ],
219         [ '%a', '0.25',    '0x1p-2' ],
220         [ '%a', '0.75',    '0x1.8p-1' ],
221         [ '%a', '3.14',    '0x1.91eb851eb851eb851eb851eb85p+1' ],
222         [ '%a', '-1',      '-0x0p+0' ],
223         [ '%a', '-3.14',   '-0x1.91eb851eb851eb851eb851eb85p+1' ],
224         [ '%a', '0.1',     '0x1.999999999999999999999999998p-4' ],
225         [ '%a', '1/7',     '0x1.249249249249249249249249248p-3' ],
226         [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea8p+0' ],
227         [ '%a', 'exp(1)',  '0x1.5bf0a8b1457695355fb8ac404e8p+1' ],
228         [ '%a', '2**-10',  '0x1p-10' ],
229         [ '%a', '2**10',   '0x1p+10' ],
230         [ '%a', '1e-09',   '0x1.12e0be826d694b2e62d01511f14p-30' ],
231         [ '%a', '1e9',     '0x1.dcd65p+29' ],
232
233         [ '%#a', '1',      '0x1.p+0' ],
234         [ '%+a', '1',      '+0x1p+0' ],
235         [ '%+a', '-1',     '-0x1p+0' ],
236         [ '% a', '1',      ' 0x1p+0' ],
237         [ '% a', '-1',     '-0x1p+0' ],
238
239         [ '%8a',      '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
240         [ '%13a',     '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
241         [ '%20a',     '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
242         [ '%.4a',     '3.14', '0x1.91ecp+1' ],
243         [ '%.5a',     '3.14', '0x1.91eb8p+1' ],
244         [ '%.6a',     '3.14', '0x1.91eb85p+1' ],
245         [ '%.20a',    '3.14',   '0x1.91eb851eb851eb851eb8p+1' ],
246         [ '%20.10a',  '3.14', '   0x1.91eb851eb8p+1' ],
247         [ '%20.15a',  '3.14',   '0x1.91eb851eb851eb8p+1' ],
248         [ '% 20.10a', '3.14', '   0x1.91eb851eb8p+1' ],
249         [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ],
250
251         [ '%30a',  '3.14',   '0x1.91eb851eb851eb851eb851eb85p+1' ],
252         [ '%-30a', '3.14',   '0x1.91eb851eb851eb851eb851eb85p+1' ],
253         [ '%030a',  '3.14',  '0x1.91eb851eb851eb851eb851eb85p+1' ],
254         [ '%-030a', '3.14',  '0x1.91eb851eb851eb851eb851eb85p+1' ],
255
256         [ '%.40a',  '3.14',
257           '0x1.91eb851eb851eb851eb851eb8500000000000000p+1' ],
258
259         [ '%A',       '3.14', '0X1.91EB851EB851EB851EB851EB85P+1' ],
260         );
261 } else {
262     print "# no hexfloat tests\n";
263 }
264
265 plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 71;
266
267 use strict;
268 use Config;
269
270 is(
271     sprintf("%.40g ",0.01),
272     sprintf("%.40g", 0.01)." ",
273     q(the sprintf "%.<number>g" optimization)
274 );
275 is(
276     sprintf("%.40f ",0.01),
277     sprintf("%.40f", 0.01)." ",
278     q(the sprintf "%.<number>f" optimization)
279 );
280
281 # cases of $i > 1 are against [perl #39126]
282 for 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");
288 }
289
290 # check simultaneous width & precision with wide characters
291 for 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
299 # Used to mangle PL_sv_undef
300 fresh_perl_like(
301     'print sprintf "xxx%n\n"; print undef',
302     qr/Modification of a read-only value attempted at - line 1\./,
303     { switches => [ '-w' ] },
304     q(%n should not be able to modify read-only constants),
305 );
306
307 # check overflows
308 for (int(~0/2+1), ~0, "9999999999999999999") {
309     is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d");
310     like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf");
311     is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d");
312     like($@, qr/^Integer overflow in format string for printf /, "overflow in printf");
313 }
314
315 # check %NNN$ for range bounds
316 {
317     my ($warn, $bad) = (0,0);
318     local $SIG{__WARN__} = sub {
319         if ($_[0] =~ /missing argument/i) {
320             $warn++
321         }
322         else {
323             $bad++
324         }
325     };
326
327     my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20));
328     my $result = sprintf $fmt, qw(a b c d);
329     is($result, "abcd", "only four valid values in $fmt");
330     is($warn, 36, "expected warnings");
331     is($bad,   0, "unexpected warnings");
332 }
333
334 # Tests for "missing argument" and "redundant argument" warnings
335 {
336     my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
337     local $SIG{__WARN__} = sub {
338         if ($_[0] =~ /missing argument/i) {
339             $warn_missing++
340         }
341         elsif ($_[0] =~ /redundant argument/i) {
342             $warn_redundant++
343         }
344         else {
345             $warn_bad++
346         }
347     };
348
349     my @tests = (
350         # The "", "%s", and "%-p" formats have special-case handling
351         # in sv.c
352         {
353             fmt  => "",
354             args => [ qw( x ) ],
355             res  => "",
356             m    => 0,
357             r    => 1,
358         },
359         {
360             fmt  => "%s",
361             args => [ qw( x y ) ],
362             res  => "x",
363             m    => 0,
364             r    => 1,
365         },
366         {
367             fmt  => "%-p",
368             args => [ qw( x y ) ],
369             res  => qr/^[0-9a-f]+$/as,
370             m    => 0,
371             r    => 1,
372         },
373         # Other non-specialcased patterns
374         {
375             fmt  => "%s : %s",
376             args => [ qw( a b c ) ],
377             res  => "a : b",
378             m    => 0,
379             r    => 1,
380         },
381         {
382             fmt  => "%s : %s : %s",
383             args => [ qw( a b c d e ) ],
384             res  => "a : b : c",
385             m    => 0,
386             # Note how we'll only warn about redundant arguments once,
387             # even though both "d" and "e" are redundant...
388             r    => 1,
389         },
390         {
391             fmt  => "%s : %s : %s",
392             args => [ ],
393             res  => " :  : ",
394             # ...But when arguments are missing we'll warn about every
395             # missing argument. This difference between the two
396             # warnings is a feature.
397             m    => 3,
398             r    => 0,
399         },
400
401         # Tests for format parameter indexes.
402         #
403         # Deciding what to do about these is a bit tricky, and so is
404         # "correctly" warning about missing arguments on them.
405         #
406         # Should we warn if you supply 4 arguments but only use
407         # argument 1,3 & 4? Or only if you supply 5 arguments and your
408         # highest used argument is 4?
409         #
410         # For some uses of this printf feature (e.g. i18n systems)
411         # it's a always a logic error to not print out every provided
412         # argument, but for some other uses skipping some might be a
413         # feature (although you could argue that then printf should be
414         # called as e.g:
415         #
416         #     printf q[%1$s %3$s], x(), undef, z();
417         #
418         # Instead of:
419         #
420         #    printf q[%1$s %3$s], x(), y(), z();
421         #
422         # Since calling the (possibly expensive) y() function is
423         # completely redundant there.
424         #
425         # We deal with all these potential problems by not even
426         # trying. If the pattern contains any format parameter indexes
427         # whatsoever we'll never warn about redundant arguments.
428         {
429             fmt  => '%1$s : %2$s',
430             args => [ qw( x y z ) ],
431             res  => "x : y",
432             m    => 0,
433             r    => 0,
434         },
435         {
436             fmt  => '%2$s : %4$s : %5$s',
437             args => [ qw( a b c d )],
438             res  => "b : d : ",
439             m    => 1,
440             r    => 0,
441         },
442         {
443             fmt  => '%s : %1$s : %s',
444             args => [ qw( x y z ) ],
445             res  => "x : x : y",
446             m    => 0,
447             r    => 0,
448         },
449
450     );
451
452     for my $i (0..$#tests) {
453         my $test = $tests[$i];
454         my $result = sprintf $test->{fmt}, @{$test->{args}};
455
456         my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'";
457         if (ref $test->{res} eq 'Regexp') {
458             like($result, $test->{res}, "$prefix got the right result");
459         } else {
460             is($result, $test->{res}, "$prefix got the right result");
461         }
462         is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings");
463         is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings");
464         is($warn_bad, 0, "$prefix No unknown warnings");
465
466         ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
467     }
468 }
469
470 {
471     foreach my $ord (0 .. 255) {
472         my $bad = 0;
473         local $SIG{__WARN__} = sub {
474             if ($_[0] !~ /^Invalid conversion in sprintf/) {
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 }
483
484 sub 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
506 my @flags = ("-", "+", " ", "0");
507 for 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
532 my $vax_float = (pack("d", 1) =~ /^[\x80\x10]\x40/);
533
534 SKIP: {
535     if ($vax_float) { skip "VAX float has no Inf or NaN", 3 }
536     # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383]
537     foreach my $n ('2**1e100', '-2**1e100', '2**1e100/2**1e100') { # +Inf, -Inf, NaN
538         eval { my $f = sprintf("%f", eval $n); };
539         is $@, "", "sprintf(\"%f\", $n)";
540     }
541 }
542
543 # test %ll formats with and without HAS_QUAD
544 my @tests = (
545   [ '%lld' => [qw( 4294967296 -100000000000000 )] ],
546   [ '%lli' => [qw( 4294967296 -100000000000000 )] ],
547   [ '%llu' => [qw( 4294967296  100000000000000 )] ],
548   [ '%Ld'  => [qw( 4294967296 -100000000000000 )] ],
549   [ '%Li'  => [qw( 4294967296 -100000000000000 )] ],
550   [ '%Lu'  => [qw( 4294967296  100000000000000 )] ],
551 );
552
553 for my $t (@tests) {
554   my($fmt, $nums) = @$t;
555   for my $num (@$nums) {
556     my $w = '';
557     local $SIG{__WARN__} = sub { $w .= shift };
558     my $sprintf_got = sprintf($fmt, $num);
559     if ($Q) {
560       is($sprintf_got, $num, "quad: $fmt -> $num");
561       is($w, '', "no warnings for: $fmt -> $num");
562     } else {
563       is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt");
564       like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt");
565       like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt");
566     }
567   }
568 }
569
570 # Check unicode vs byte length
571 for my $width (1,2,3,4,5,6,7) {
572     for my $precis (1,2,3,4,5,6,7) {
573         my $v = "\x{20ac}\x{20ac}";
574         my $format = "%" . $width . "." . $precis . "s";
575         my $chars = ($precis > 2 ? 2 : $precis);
576         my $space = ($width < 2 ? 0 : $width - $chars);
577         fresh_perl_is(
578             'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2',
579             "$space$chars",
580             {},
581             q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"),
582         );
583     }
584 }
585
586 # Overload count
587 package o {
588     use overload
589         '""', sub { ++our $count; $_[0][0]; },
590         '0+', sub { ++our $numcount; $_[0][1]; }
591 }
592 my $o = bless ["\x{100}",42], o::;
593 () = sprintf "%1s", $o;
594 is $o::count, '1', 'sprinf %1s overload count';
595 $o::count = 0;
596 () = sprintf "%.1s", $o;
597 is $o::count, '1', 'sprinf %.1s overload count';
598 $o::count = 0;
599 () = sprintf "%d", $o;
600 is $o::count,    0, 'sprintf %d string overload count is 0';
601 is $o::numcount, 1, 'sprintf %d number overload count is 1';
602
603 SKIP: {  # hexfp
604     if ($vax_float) { skip "VAX float no hexfp", scalar @hexfloat }
605
606 my $ppc_linux = $Config{archname} =~ /^(?:ppc|power(?:pc)?)(?:64)?-linux/;
607 my $irix_ld   = $Config{archname} =~ /^IP\d+-irix-ld$/;
608
609 for my $t (@hexfloat) {
610     my ($format, $arg, $expected) = @$t;
611     $arg = eval $arg;
612     my $result = sprintf($format, $arg);
613     my $ok = $result eq $expected;
614     # For certain platforms (all of which are currently double-double,
615     # but different implementations, GNU vs vendor, two different archs
616     # (ppc and mips), and two different libm interfaces) we have some
617     # bits-in-the-last-hexdigit differences.
618     # Patch them up as TODOs instead of deadly errors.
619     if ($doubledouble && $ppc_linux && $arg =~ /^2.71828/) {
620         # gets  '0x1.5bf0a8b1457695355fb8ac404ecp+1'
621         # wants '0x1.5bf0a8b1457695355fb8ac404e8p+1'
622         local $::TODO = "$Config{archname} exp(1)";
623         ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
624         next;
625     }
626     if ($doubledouble && $irix_ld && $arg =~ /^1.41421/) {
627         # gets  '0x1.6a09e667f3bcc908b2fb1366eacp+0'
628         # wants '0x1.6a09e667f3bcc908b2fb1366ea8p+0'
629         local $::TODO = "$Config{archname} sqrt(2)";
630         ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
631         next;
632     }
633     unless ($ok) {
634         # It seems that there can be difference in the last bits:
635         # [perl #122578]
636         #      got "0x1.5bf0a8b14576ap+1"
637         # expected "0x1.5bf0a8b145769p+1"
638         # (Android on ARM)
639         #
640         # Exact cause unknown but suspecting different fp rounding modes,
641         # (towards zero? towards +inf? towards -inf?) about which Perl
642         # is blissfully unaware.
643         #
644         # Try extracting one (or sometimes two) last mantissa
645         # hexdigits, and see if they differ in value by one.
646         my ($rh, $eh) = ($result, $expected);
647         sub extract_prefix {
648             ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1;
649         }
650         my $rp = extract_prefix($rh);
651         my $ep = extract_prefix($eh);
652         print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n";
653         if ($rp eq $ep) { # If prefixes match.
654             sub extract_exponent {
655                 ($_[0] =~ s/([pP][+-]?\d+)//) && return $1;
656             }
657             my $re = extract_exponent($rh);
658             my $ee = extract_exponent($eh);
659             print "# re = $re, ee = $ee (rh $rh, eh $eh)\n";
660             if ($re eq $ee) { # If exponents match.
661                 # Remove the common prefix of the mantissa bits.
662                 my $la = length($rh);
663                 my $lb = length($eh);
664                 my $i;
665                 for ($i = 0; $i < $la && $i < $lb; $i++) {
666                     last if substr($rh, $i, 1) ne substr($eh, $i, 1);
667                 }
668                 $rh = substr($rh, $i);
669                 $eh = substr($eh, $i);
670                 print "# (rh $rh, eh $eh)\n";
671                 if ($rh ne $eh) {
672                     # If necessary, pad the shorter one on the right
673                     # with one zero (for example "...1f" vs "...2",
674                     # we want to compare "1f" to "20").
675                     if (length $rh < length $eh) {
676                         $rh .= '0';
677                     } elsif (length $eh < length $rh) {
678                         $eh .= '0';
679                     }
680                     print "# (rh $rh, eh $eh)\n";
681                     if (length $eh == length $rh) {
682                         if (abs(hex($eh) - hex($rh)) == 1) {
683                             $ok = 1;
684                         }
685                     }
686                 }
687             }
688         }
689     }
690     ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
691 }
692
693 } # SKIP: # hexfp
694
695 # double-double long double %a special testing.
696 SKIP: {
697     skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef')
698          . " longdblkind=$Config{longdblkind} os=$^O", 6)
699         unless ($Config{uselongdouble} &&
700                 ($Config{longdblkind} == 5 ||
701                  $Config{longdblkind} == 6)
702                 # Gating on 'linux' (ppc) here is due to the differing
703                 # double-double implementations: other (also big-endian)
704                 # double-double platforms (e.g. AIX on ppc or IRIX on mips)
705                 # do not behave similarly.
706                 && $^O eq 'linux'
707                 );
708     # [rt.perl.org 125633]
709     like(sprintf("%La\n", eval '(2**1020) + (2**-1072)'),
710          qr/^0x1.0{522}1p\+1020$/);
711     like(sprintf("%La\n", eval '(2**1021) + (2**-1072)'),
712          qr/^0x1.0{523}8p\+1021$/);
713     like(sprintf("%La\n", eval '(2**1022) + (2**-1072)'),
714          qr/^0x1.0{523}4p\+1022$/);
715     like(sprintf("%La\n", eval '(2**1023) + (2**-1072)'),
716          qr/^0x1.0{523}2p\+1023$/);
717     like(sprintf("%La\n", eval '(2**1023) + (2**-1073)'),
718          qr/^0x1.0{523}1p\+1023$/);
719     like(sprintf("%La\n", eval '(2**1023) + (2**-1074)'),
720          qr/^0x1.0{524}8p\+1023$/);
721 }
722
723 SKIP: {
724     skip("negative zero not available\n", 3)
725         unless sprintf('%+f', -0.0) =~ /^-0/;
726     is(sprintf("%a", -0.0), "-0x0p+0", "negative zero");
727     is(sprintf("%+a", -0.0), "-0x0p+0", "negative zero");
728     is(sprintf("%.13a", -0.0), "-0x0.0000000000000p+0", "negative zero");
729 }
730
731 SKIP: {
732     # [perl #127183] Non-canonical hexadecimal floats are parsed prematurely
733
734     # IEEE 754 64-bit
735     skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53", 3)
736         unless $Config{nv_preserves_uv_bits} == 53;
737
738     {
739         # The 0x0.b17217f7d1cf78p0 is the original LHS value
740         # from [perl #127183], its bits are 0x162e42fefa39ef << 3,
741         # resulting in a non-canonical form of hexfp, where the most
742         # significant bit is zero, instead of one.
743         is(sprintf("%a", 0x0.b17217f7d1cf78p0 - 0x1.62e42fefa39efp-1),
744            "0x0p+0",
745            "non-canonical form [perl #127183]");
746     }
747
748     {
749         no warnings 'overflow';  # Not the point here.
750
751         # The 0x058b90bfbe8e7bc is 0x162e42fefa39ef << 2,
752         # the 0x02c5c85fdf473de is 0x162e42fefa39ef << 1,
753         # see above.
754         is(sprintf("%a", 0x0.58b90bfbe8e7bcp1 - 0x1.62e42fefa39efp-1),
755            "0x0p+0",
756            "non-canonical form");
757
758         is(sprintf("%a", 0x0.2c5c85fdf473dep2 - 0x1.62e42fefa39efp-1),
759            "0x0p+0",
760            "non-canonical form");
761     }
762 }
763
764 # [rt.perl.org #128843]
765 SKIP: {
766     my @subnormals = (
767         # Keep these as strings so that non-IEEE-754 don't trip over them.
768         [ '1e-320', '%a', '0x1.fap-1064' ],
769         [ '1e-321', '%a', '0x1.94p-1067' ],
770         [ '1e-322', '%a', '0x1.4p-1070' ],
771         [ '1e-323', '%a', '0x1p-1073' ],
772         [ '1e-324', '%a', '0x0p+0' ],  # underflow
773         [ '3e-320', '%a', '0x1.7b8p-1062' ],
774         [ '3e-321', '%a', '0x1.2f8p-1065' ],
775         [ '3e-322', '%a', '0x1.e8p-1069' ],
776         [ '3e-323', '%a', '0x1.8p-1072' ],
777         [ '3e-324', '%a', '0x1p-1074' ], # the smallest possible value
778         [ '7e-320', '%a', '0x1.bacp-1061' ],
779         [ '7e-321', '%a', '0x1.624p-1064' ],
780         [ '7e-322', '%a', '0x1.1cp-1067' ],
781         [ '7e-323', '%a', '0x1.cp-1071' ],
782         [ '7e-324', '%a', '0x1p-1074' ], # the smallest possible value, again
783         [ '3e-320', '%.4a', '0x1.7b80p-1062' ],
784         [ '3e-321', '%.4a', '0x1.2f80p-1065' ],
785         [ '3e-322', '%.4a', '0x1.e800p-1069' ],
786         [ '3e-323', '%.4a', '0x1.8000p-1072' ],
787         [ '3e-324', '%.4a', '0x1.0000p-1074' ],
788         [ '3e-320', '%.1a', '0x1.8p-1062' ],
789         [ '3e-321', '%.1a', '0x1.3p-1065' ],
790         [ '3e-322', '%.1a', '0x1.ep-1069' ],
791         [ '3e-323', '%.1a', '0x1.8p-1072' ],
792         [ '3e-324', '%.1a', '0x1.0p-1074' ],
793         );
794
795     # IEEE 754 64-bit
796     skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53",
797          scalar @subnormals + 34)
798         unless $Config{nv_preserves_uv_bits} == 53;
799
800     for my $t (@subnormals) {
801         my $s = sprintf($t->[1], $t->[0]);
802         is($s, $t->[2], "subnormal @$t got $s");
803     }
804
805     # [rt.perl.org #128888]
806     is(sprintf("%a", 1.03125),   "0x1.08p+0");
807     is(sprintf("%.1a", 1.03125), "0x1.0p+0");
808     is(sprintf("%.0a", 1.03125), "0x1p+0", "[rt.perl.org #128888]");
809
810    # [rt.perl.org #128889]
811    is(sprintf("%.*a", -1, 1.03125), "0x1.08p+0", "[rt.perl.org #128889]");
812
813    # [rt.perl.org #128890]
814    is(sprintf("%a", 0x1.18p+0), "0x1.18p+0");
815    is(sprintf("%.1a", 0x1.08p+0), "0x1.0p+0");
816    is(sprintf("%.1a", 0x1.18p+0), "0x1.2p+0", "[rt.perl.org #128890]");
817    is(sprintf("%.1a", 0x1.28p+0), "0x1.2p+0");
818    is(sprintf("%.1a", 0x1.38p+0), "0x1.4p+0");
819    is(sprintf("%.1a", 0x1.48p+0), "0x1.4p+0");
820    is(sprintf("%.1a", 0x1.58p+0), "0x1.6p+0");
821    is(sprintf("%.1a", 0x1.68p+0), "0x1.6p+0");
822    is(sprintf("%.1a", 0x1.78p+0), "0x1.8p+0");
823    is(sprintf("%.1a", 0x1.88p+0), "0x1.8p+0");
824    is(sprintf("%.1a", 0x1.98p+0), "0x1.ap+0");
825    is(sprintf("%.1a", 0x1.a8p+0), "0x1.ap+0");
826    is(sprintf("%.1a", 0x1.b8p+0), "0x1.cp+0");
827    is(sprintf("%.1a", 0x1.c8p+0), "0x1.cp+0");
828    is(sprintf("%.1a", 0x1.d8p+0), "0x1.ep+0");
829    is(sprintf("%.1a", 0x1.e8p+0), "0x1.ep+0");
830    is(sprintf("%.1a", 0x1.f8p+0), "0x2.0p+0");
831
832    is(sprintf("%.1a", 0x1.10p+0), "0x1.1p+0");
833    is(sprintf("%.1a", 0x1.17p+0), "0x1.1p+0");
834    is(sprintf("%.1a", 0x1.19p+0), "0x1.2p+0");
835    is(sprintf("%.1a", 0x1.1fp+0), "0x1.2p+0");
836
837    is(sprintf("%.2a", 0x1.fffp+0), "0x2.00p+0");
838    is(sprintf("%.2a", 0xf.fffp+0), "0x2.00p+3");
839
840    # [rt.perl.org #128893]
841    is(sprintf("%020a", 1.5), "0x0000000000001.8p+0");
842    is(sprintf("%020a", -1.5), "-0x000000000001.8p+0", "[rt.perl.org #128893]");
843    is(sprintf("%+020a", 1.5), "+0x000000000001.8p+0", "[rt.perl.org #128893]");
844    is(sprintf("% 020a", 1.5), " 0x000000000001.8p+0", "[rt.perl.org #128893]");
845    is(sprintf("%20a", -1.5), "           -0x1.8p+0");
846    is(sprintf("%+20a", 1.5), "           +0x1.8p+0");
847    is(sprintf("% 20a", 1.5), "            0x1.8p+0");
848 }