Commit | Line | Data |
---|---|---|
1d917b39 RGS |
1 | #!./perl -w |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | require './test.pl'; | |
7 | } | |
8 | ||
9ef5ed94 | 9 | plan tests => 1368; |
53f65a9e HS |
10 | |
11 | use strict; | |
12 | use Config; | |
1d917b39 RGS |
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 | ); | |
cc61b222 TS |
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"); | |
6c94ec8b | 32 | } |
fc7325bb | 33 | |
59b61096 AV |
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 | ||
fc7325bb GA |
43 | # Used to mangle PL_sv_undef |
44 | fresh_perl_is( | |
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), | |
863811b2 DM |
49 | ); |
50 | ||
2fba7546 | 51 | # check overflows |
45e52d63 | 52 | for (int(~0/2+1), ~0, "9999999999999999999") { |
2fba7546 GA |
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 prtf /, "overflow in printf"); | |
57 | } | |
863811b2 | 58 | |
2fba7546 | 59 | # check %NNN$ for range bounds |
863811b2 DM |
60 | { |
61 | my ($warn, $bad) = (0,0); | |
62 | local $SIG{__WARN__} = sub { | |
63 | if ($_[0] =~ /uninitialized/) { | |
64 | $warn++ | |
65 | } | |
66 | else { | |
67 | $bad++ | |
68 | } | |
69 | }; | |
2fba7546 | 70 | |
45e52d63 | 71 | my $fmt = join('', map("%$_\$s%" . ((1 << 31)-$_) . '$s', 1..20)); |
2fba7546 GA |
72 | my $result = sprintf $fmt, qw(a b c d); |
73 | is($result, "abcd", "only four valid values in $fmt"); | |
863811b2 DM |
74 | is($warn, 36, "expected warnings"); |
75 | is($bad, 0, "unexpected warnings"); | |
76 | } | |
77 | ||
343ef749 NC |
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 | } | |
9911cee9 TS |
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 | ||
9c2a5cfe B |
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 | } | |
53f65a9e HS |
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 = ( | |
8ff953de MHM |
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 )] ], | |
53f65a9e HS |
157 | ); |
158 | ||
159 | for my $t (@tests) { | |
8ff953de MHM |
160 | my($fmt, $nums) = @$t; |
161 | for my $num (@$nums) { | |
53f65a9e HS |
162 | my $w; local $SIG{__WARN__} = sub { $w = shift }; |
163 | is(sprintf($fmt, $num), $Q ? $num : $fmt, "quad: $fmt -> $num"); | |
1d1ac7bc | 164 | like($w, $Q ? '' : qr/Invalid conversion in sprintf: "$fmt"/, "warning: $fmt"); |
53f65a9e HS |
165 | } |
166 | } | |
167 | ||
9ef5ed94 AV |
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 | } |