This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
87e5e50bbe90c6026360b4386055ea3ad0cd7d08
[perl5.git] / t / op / sprintf2.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }   
8
9 plan tests => 1368;
10
11 use strict;
12 use Config;
13
14 is(
15     sprintf("%.40g ",0.01),
16     sprintf("%.40g", 0.01)." ",
17     q(the sprintf "%.<number>g" optimization)
18 );
19 is(
20     sprintf("%.40f ",0.01),
21     sprintf("%.40f", 0.01)." ",
22     q(the sprintf "%.<number>f" optimization)
23 );
24
25 # cases of $i > 1 are against [perl #39126]
26 for my $i (1, 5, 10, 20, 50, 100) {
27     chop(my $utf8_format = "%-*s\x{100}");
28     my $string = "\xB4"x$i;        # latin1 ACUTE or ebcdic COPYRIGHT
29     my $expect = $string."  "x$i;  # followed by 2*$i spaces
30     is(sprintf($utf8_format, 3*$i, $string), $expect,
31        "width calculation under utf8 upgrade, length=$i");
32 }
33
34 # check simultaneous width & precision with wide characters
35 for my $i (1, 3, 5, 10) {
36     my $string = "\x{0410}"x($i+10);   # cyrillic capital A
37     my $expect = "\x{0410}"x$i;        # cut down to exactly $i characters
38     my $format = "%$i.${i}s";
39     is(sprintf($format, $string), $expect,
40        "width & precision interplay with utf8 strings, length=$i");
41 }
42
43 # Used to mangle PL_sv_undef
44 fresh_perl_like(
45     'print sprintf "xxx%n\n"; print undef',
46     'Modification of a read-only value attempted at - line 1\.',
47     { switches => [ '-w' ] },
48     q(%n should not be able to modify read-only constants),
49 );
50
51 # check overflows
52 for (int(~0/2+1), ~0, "9999999999999999999") {
53     is(eval {sprintf "%${_}d", 0}, undef, "no sprintf result expected %${_}d");
54     like($@, qr/^Integer overflow in format string for sprintf /, "overflow in sprintf");
55     is(eval {printf "%${_}d\n", 0}, undef, "no printf result expected %${_}d");
56     like($@, qr/^Integer overflow in format string for printf /, "overflow in printf");
57 }
58
59 # check %NNN$ for range bounds
60 {
61     my ($warn, $bad) = (0,0);
62     local $SIG{__WARN__} = sub {
63         if ($_[0] =~ /missing argument/i) {
64             $warn++
65         }
66         else {
67             $bad++
68         }
69     };
70
71     my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20));
72     my $result = sprintf $fmt, qw(a b c d);
73     is($result, "abcd", "only four valid values in $fmt");
74     is($warn, 36, "expected warnings");
75     is($bad,   0, "unexpected warnings");
76 }
77
78 {
79     foreach my $ord (0 .. 255) {
80         my $bad = 0;
81         local $SIG{__WARN__} = sub {
82             if ($_[0] !~ /^Invalid conversion in sprintf/) {
83                 warn $_[0];
84                 $bad++;
85             }
86         };
87         my $r = eval {sprintf '%v' . chr $ord};
88         is ($bad, 0, "pattern '%v' . chr $ord");
89     }
90 }
91
92 sub mysprintf_int_flags {
93     my ($fmt, $num) = @_;
94     die "wrong format $fmt" if $fmt !~ /^%([-+ 0]+)([1-9][0-9]*)d\z/;
95     my $flag  = $1;
96     my $width = $2;
97     my $sign  = $num < 0 ? '-' :
98                 $flag =~ /\+/ ? '+' :
99                 $flag =~ /\ / ? ' ' :
100                 '';
101     my $abs   = abs($num);
102     my $padlen = $width - length($sign.$abs);
103     return
104         $flag =~ /0/ && $flag !~ /-/ # do zero padding
105             ? $sign . '0' x $padlen . $abs
106             : $flag =~ /-/ # left or right
107                 ? $sign . $abs . ' ' x $padlen
108                 : ' ' x $padlen . $sign . $abs;
109 }
110
111 # Whole tests for "%4d" with 2 to 4 flags;
112 # total counts: 3 * (4**2 + 4**3 + 4**4) == 1008
113
114 my @flags = ("-", "+", " ", "0");
115 for my $num (0, -1, 1) {
116     for my $f1 (@flags) {
117         for my $f2 (@flags) {
118             for my $f3 ('', @flags) { # '' for doubled flags
119                 my $flag = $f1.$f2.$f3;
120                 my $width = 4;
121                 my $fmt   = '%'."${flag}${width}d";
122                 my $result = sprintf($fmt, $num);
123                 my $expect = mysprintf_int_flags($fmt, $num);
124                 is($result, $expect, qq/sprintf("$fmt",$num)/);
125
126                 next if $f3 eq '';
127
128                 for my $f4 (@flags) { # quadrupled flags
129                     my $flag = $f1.$f2.$f3.$f4;
130                     my $fmt   = '%'."${flag}${width}d";
131                     my $result = sprintf($fmt, $num);
132                     my $expect = mysprintf_int_flags($fmt, $num);
133                     is($result, $expect, qq/sprintf("$fmt",$num)/);
134                 }
135             }
136         }
137     }
138 }
139
140 # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383]
141 foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN
142     eval { my $f = sprintf("%f", $n); };
143     is $@, "", "sprintf(\"%f\", $n)";
144 }
145
146 # test %ll formats with and without HAS_QUAD
147 eval { my $q = pack "q", 0 };
148 my $Q = $@ eq '';
149
150 my @tests = (
151   [ '%lld' => [qw( 4294967296 -100000000000000 )] ],
152   [ '%lli' => [qw( 4294967296 -100000000000000 )] ],
153   [ '%llu' => [qw( 4294967296  100000000000000 )] ],
154   [ '%Ld'  => [qw( 4294967296 -100000000000000 )] ],
155   [ '%Li'  => [qw( 4294967296 -100000000000000 )] ],
156   [ '%Lu'  => [qw( 4294967296  100000000000000 )] ],
157 );
158
159 for my $t (@tests) {
160   my($fmt, $nums) = @$t;
161   for my $num (@$nums) {
162     my $w; local $SIG{__WARN__} = sub { $w = shift };
163     is(sprintf($fmt, $num), $Q ? $num : $fmt, "quad: $fmt -> $num");
164     like($w, $Q ? '' : qr/Invalid conversion in sprintf: "$fmt"/, "warning: $fmt");
165   }
166 }
167
168 # Check unicode vs byte length
169 for my $width (1,2,3,4,5,6,7) {
170     for my $precis (1,2,3,4,5,6,7) {
171         my $v = "\x{20ac}\x{20ac}";
172         my $format = "%" . $width . "." . $precis . "s";
173         my $chars = ($precis > 2 ? 2 : $precis);
174         my $space = ($width < 2 ? 0 : $width - $chars);
175         fresh_perl_is(
176             'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2',
177             "$space$chars",
178             {},
179             q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"),
180         );
181     }
182 }