This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
6fd0bde072c2ab6bdd1d2f418875db02bb33f5d5
[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 plan tests => 1406 + ($Q ? 0 : 12);
16
17 use strict;
18 use Config;
19
20 is(
21     sprintf("%.40g ",0.01),
22     sprintf("%.40g", 0.01)." ",
23     q(the sprintf "%.<number>g" optimization)
24 );
25 is(
26     sprintf("%.40f ",0.01),
27     sprintf("%.40f", 0.01)." ",
28     q(the sprintf "%.<number>f" optimization)
29 );
30
31 # cases of $i > 1 are against [perl #39126]
32 for my $i (1, 5, 10, 20, 50, 100) {
33     chop(my $utf8_format = "%-*s\x{100}");
34     my $string = "\xB4"x$i;        # latin1 ACUTE or ebcdic COPYRIGHT
35     my $expect = $string."  "x$i;  # followed by 2*$i spaces
36     is(sprintf($utf8_format, 3*$i, $string), $expect,
37        "width calculation under utf8 upgrade, length=$i");
38 }
39
40 # check simultaneous width & precision with wide characters
41 for my $i (1, 3, 5, 10) {
42     my $string = "\x{0410}"x($i+10);   # cyrillic capital A
43     my $expect = "\x{0410}"x$i;        # cut down to exactly $i characters
44     my $format = "%$i.${i}s";
45     is(sprintf($format, $string), $expect,
46        "width & precision interplay with utf8 strings, length=$i");
47 }
48
49 # Used to mangle PL_sv_undef
50 fresh_perl_like(
51     'print sprintf "xxx%n\n"; print undef',
52     qr/Modification of a read-only value attempted at - line 1\./,
53     { switches => [ '-w' ] },
54     q(%n should not be able to modify read-only constants),
55 );
56
57 # check overflows
58 for (int(~0/2+1), ~0, "9999999999999999999") {
59     is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d");
60     like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf");
61     is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d");
62     like($@, qr/^Integer overflow in format string for printf /, "overflow in printf");
63 }
64
65 # check %NNN$ for range bounds
66 {
67     my ($warn, $bad) = (0,0);
68     local $SIG{__WARN__} = sub {
69         if ($_[0] =~ /missing argument/i) {
70             $warn++
71         }
72         else {
73             $bad++
74         }
75     };
76
77     my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20));
78     my $result = sprintf $fmt, qw(a b c d);
79     is($result, "abcd", "only four valid values in $fmt");
80     is($warn, 36, "expected warnings");
81     is($bad,   0, "unexpected warnings");
82 }
83
84 # Tests for "missing argument" and "redundant argument" warnings
85 {
86     my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
87     local $SIG{__WARN__} = sub {
88         if ($_[0] =~ /missing argument/i) {
89             $warn_missing++
90         }
91         elsif ($_[0] =~ /redundant argument/i) {
92             $warn_redundant++
93         }
94         else {
95             $warn_bad++
96         }
97     };
98
99     my @tests = (
100         # The "", "%s", and "%-p" formats have special-case handling
101         # in sv.c
102         {
103             fmt  => "",
104             args => [ qw( x ) ],
105             res  => "",
106             m    => 0,
107             r    => 1,
108         },
109         {
110             fmt  => "%s",
111             args => [ qw( x y ) ],
112             res  => "x",
113             m    => 0,
114             r    => 1,
115         },
116         {
117             fmt  => "%-p",
118             args => [ qw( x y ) ],
119             res  => qr/^[0-9a-f]+$/as,
120             m    => 0,
121             r    => 1,
122         },
123         # Other non-specialcased patterns
124         {
125             fmt  => "%s : %s",
126             args => [ qw( a b c ) ],
127             res  => "a : b",
128             m    => 0,
129             r    => 1,
130         },
131         {
132             fmt  => "%s : %s : %s",
133             args => [ qw( a b c d e ) ],
134             res  => "a : b : c",
135             m    => 0,
136             # Note how we'll only warn about redundant arguments once,
137             # even though both "d" and "e" are redundant...
138             r    => 1,
139         },
140         {
141             fmt  => "%s : %s : %s",
142             args => [ ],
143             res  => " :  : ",
144             # ...But when arguments are missing we'll warn about every
145             # missing argument. This difference between the two
146             # warnings is a feature.
147             m    => 3,
148             r    => 0,
149         },
150
151         # Tests for format parameter indexes.
152         #
153         # Deciding what to do about these is a bit tricky, and so is
154         # "correctly" warning about missing arguments on them.
155         #
156         # Should we warn if you supply 4 arguments but only use
157         # argument 1,3 & 4? Or only if you supply 5 arguments and your
158         # highest used argument is 4?
159         #
160         # For some uses of this printf feature (e.g. i18n systems)
161         # it's a always a logic error to not print out every provided
162         # argument, but for some other uses skipping some might be a
163         # feature (although you could argue that then printf should be
164         # called as e.g:
165         #
166         #     printf q[%1$s %3$s], x(), undef, z();
167         #
168         # Instead of:
169         #
170         #    printf q[%1$s %3$s], x(), y(), z();
171         #
172         # Since calling the (possibly expensive) y() function is
173         # completely redundant there.
174         #
175         # We deal with all these potential problems by not even
176         # trying. If the pattern contains any format parameter indexes
177         # whatsoever we'll never warn about redundant arguments.
178         {
179             fmt  => '%1$s : %2$s',
180             args => [ qw( x y z ) ],
181             res  => "x : y",
182             m    => 0,
183             r    => 0,
184         },
185         {
186             fmt  => '%2$s : %4$s : %5$s',
187             args => [ qw( a b c d )],
188             res  => "b : d : ",
189             m    => 1,
190             r    => 0,
191         },
192         {
193             fmt  => '%s : %1$s : %s',
194             args => [ qw( x y z ) ],
195             res  => "x : x : y",
196             m    => 0,
197             r    => 0,
198         },
199
200     );
201
202     for my $i (0..$#tests) {
203         my $test = $tests[$i];
204         my $result = sprintf $test->{fmt}, @{$test->{args}};
205
206         my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'";
207         if (ref $test->{res} eq 'Regexp') {
208             like($result, $test->{res}, "$prefix got the right result");
209         } else {
210             is($result, $test->{res}, "$prefix got the right result");
211         }
212         is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings");
213         is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings");
214         is($warn_bad, 0, "$prefix No unknown warnings");
215
216         ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0);
217     }
218 }
219
220 {
221     foreach my $ord (0 .. 255) {
222         my $bad = 0;
223         local $SIG{__WARN__} = sub {
224             if ($_[0] !~ /^Invalid conversion in sprintf/) {
225                 warn $_[0];
226                 $bad++;
227             }
228         };
229         my $r = eval {sprintf '%v' . chr $ord};
230         is ($bad, 0, "pattern '%v' . chr $ord");
231     }
232 }
233
234 sub mysprintf_int_flags {
235     my ($fmt, $num) = @_;
236     die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/;
237     my $flag  = $1;
238     my $width = $2;
239     my $sign  = $num < 0 ? '-' :
240                 $flag =~ /\+/ ? '+' :
241                 $flag =~ /\ / ? ' ' :
242                 '';
243     my $abs   = abs($num);
244     my $padlen = $width - length($sign.$abs);
245     return
246         $flag =~ /0/ && $flag !~ /-/ # do zero padding
247             ? $sign . '0' x $padlen . $abs
248             : $flag =~ /-/ # left or right
249                 ? $sign . $abs . ' ' x $padlen
250                 : ' ' x $padlen . $sign . $abs;
251 }
252
253 # Whole tests for "%4d" with 2 to 4 flags;
254 # total counts: 3 * (4**2 + 4**3 + 4**4) == 1008
255
256 my @flags = ("-", "+", " ", "0");
257 for my $num (0, -1, 1) {
258     for my $f1 (@flags) {
259         for my $f2 (@flags) {
260             for my $f3 ('', @flags) { # '' for doubled flags
261                 my $flag = $f1.$f2.$f3;
262                 my $width = 4;
263                 my $fmt   = '%'."${flag}${width}d";
264                 my $result = sprintf($fmt, $num);
265                 my $expect = mysprintf_int_flags($fmt, $num);
266                 is($result, $expect, qq/sprintf("$fmt",$num)/);
267
268                 next if $f3 eq '';
269
270                 for my $f4 (@flags) { # quadrupled flags
271                     my $flag = $f1.$f2.$f3.$f4;
272                     my $fmt   = '%'."${flag}${width}d";
273                     my $result = sprintf($fmt, $num);
274                     my $expect = mysprintf_int_flags($fmt, $num);
275                     is($result, $expect, qq/sprintf("$fmt",$num)/);
276                 }
277             }
278         }
279     }
280 }
281
282 # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383]
283 foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN
284     eval { my $f = sprintf("%f", $n); };
285     is $@, "", "sprintf(\"%f\", $n)";
286 }
287
288 # test %ll formats with and without HAS_QUAD
289 my @tests = (
290   [ '%lld' => [qw( 4294967296 -100000000000000 )] ],
291   [ '%lli' => [qw( 4294967296 -100000000000000 )] ],
292   [ '%llu' => [qw( 4294967296  100000000000000 )] ],
293   [ '%Ld'  => [qw( 4294967296 -100000000000000 )] ],
294   [ '%Li'  => [qw( 4294967296 -100000000000000 )] ],
295   [ '%Lu'  => [qw( 4294967296  100000000000000 )] ],
296 );
297
298 for my $t (@tests) {
299   my($fmt, $nums) = @$t;
300   for my $num (@$nums) {
301     my $w = '';
302     local $SIG{__WARN__} = sub { $w .= shift };
303     my $sprintf_got = sprintf($fmt, $num);
304     if ($Q) {
305       is($sprintf_got, $num, "quad: $fmt -> $num");
306       is($w, '', "no warnings for: $fmt -> $num");
307     } else {
308       is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt");
309       like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt");
310       like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt");
311     }
312   }
313 }
314
315 # Check unicode vs byte length
316 for my $width (1,2,3,4,5,6,7) {
317     for my $precis (1,2,3,4,5,6,7) {
318         my $v = "\x{20ac}\x{20ac}";
319         my $format = "%" . $width . "." . $precis . "s";
320         my $chars = ($precis > 2 ? 2 : $precis);
321         my $space = ($width < 2 ? 0 : $width - $chars);
322         fresh_perl_is(
323             'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2',
324             "$space$chars",
325             {},
326             q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"),
327         );
328     }
329 }
330
331 # Overload count
332 package o { use overload '""', sub { ++our $count; $_[0][0]; } }
333 my $o = bless ["\x{100}"], o::;
334 () = sprintf "%1s", $o;
335 is $o::count, '1', 'sprinf %1s overload count';
336 $o::count = 0;
337 () = sprintf "%.1s", $o;
338 is $o::count, '1', 'sprinf %.1s overload count';