Commit | Line | Data |
---|---|---|
1d917b39 RGS |
1 | #!./perl -w |
2 | ||
6715405f FC |
3 | # Tests for sprintf that do not fit the format of sprintf.t. |
4 | ||
1d917b39 RGS |
5 | BEGIN { |
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. |
12 | eval { my $q = pack "q", 0 }; | |
13 | my $Q = $@ eq ''; | |
14 | ||
261d007a JH |
15 | my $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. | |
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"; | |
9e67a8c1 | 24 | print "# uselongdouble = " . ($Config{uselongdouble} // 'undef') . "\n"; |
40bca5ae JH |
25 | if ($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 |
266 | use strict; |
267 | use Config; | |
1d917b39 RGS |
268 | |
269 | is( | |
270 | sprintf("%.40g ",0.01), | |
271 | sprintf("%.40g", 0.01)." ", | |
272 | q(the sprintf "%.<number>g" optimization) | |
273 | ); | |
274 | is( | |
275 | sprintf("%.40f ",0.01), | |
276 | sprintf("%.40f", 0.01)." ", | |
277 | q(the sprintf "%.<number>f" optimization) | |
278 | ); | |
cc61b222 TS |
279 | |
280 | # cases of $i > 1 are against [perl #39126] | |
281 | for 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 |
290 | for 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 | 299 | fresh_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 | 307 | for (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 TS |
482 | |
483 | sub 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 | ||
505 | my @flags = ("-", "+", " ", "0"); | |
506 | for 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 JH |
531 | my $vax_float = (pack("d", 1) =~ /^[\x80\x10]\x40/); |
532 | ||
533 | SKIP: { | |
534 | if ($vax_float) { skip "VAX float has no Inf or NaN", 3 } | |
535 | # test that %f doesn't panic with +Inf, -Inf, NaN [perl #45383] | |
536 | foreach my $n ('2**1e100', '-2**1e100', '2**1e100/2**1e100') { # +Inf, -Inf, NaN | |
537 | eval { my $f = sprintf("%f", eval $n); }; | |
538 | is $@, "", "sprintf(\"%f\", $n)"; | |
539 | } | |
9c2a5cfe | 540 | } |
53f65a9e HS |
541 | |
542 | # test %ll formats with and without HAS_QUAD | |
53f65a9e | 543 | my @tests = ( |
8ff953de MHM |
544 | [ '%lld' => [qw( 4294967296 -100000000000000 )] ], |
545 | [ '%lli' => [qw( 4294967296 -100000000000000 )] ], | |
546 | [ '%llu' => [qw( 4294967296 100000000000000 )] ], | |
547 | [ '%Ld' => [qw( 4294967296 -100000000000000 )] ], | |
548 | [ '%Li' => [qw( 4294967296 -100000000000000 )] ], | |
549 | [ '%Lu' => [qw( 4294967296 100000000000000 )] ], | |
53f65a9e HS |
550 | ); |
551 | ||
552 | for my $t (@tests) { | |
8ff953de MHM |
553 | my($fmt, $nums) = @$t; |
554 | for my $num (@$nums) { | |
826af139 AB |
555 | my $w = ''; |
556 | local $SIG{__WARN__} = sub { $w .= shift }; | |
557 | my $sprintf_got = sprintf($fmt, $num); | |
558 | if ($Q) { | |
559 | is($sprintf_got, $num, "quad: $fmt -> $num"); | |
560 | is($w, '', "no warnings for: $fmt -> $num"); | |
561 | } else { | |
562 | is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt"); | |
563 | like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt"); | |
3101bb05 | 564 | like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt"); |
826af139 | 565 | } |
53f65a9e HS |
566 | } |
567 | } | |
568 | ||
9ef5ed94 AV |
569 | # Check unicode vs byte length |
570 | for my $width (1,2,3,4,5,6,7) { | |
571 | for my $precis (1,2,3,4,5,6,7) { | |
572 | my $v = "\x{20ac}\x{20ac}"; | |
573 | my $format = "%" . $width . "." . $precis . "s"; | |
574 | my $chars = ($precis > 2 ? 2 : $precis); | |
575 | my $space = ($width < 2 ? 0 : $width - $chars); | |
576 | fresh_perl_is( | |
577 | 'my $v = "\x{20ac}\x{20ac}"; my $x = sprintf "'.$format.'", $v; $x =~ /^(\s*)(\S*)$/; print "$_" for map {length} $1, $2', | |
578 | "$space$chars", | |
579 | {}, | |
580 | q(sprintf ").$format.q(", "\x{20ac}\x{20ac}"), | |
581 | ); | |
582 | } | |
583 | } | |
667f6f15 FC |
584 | |
585 | # Overload count | |
1d55083c FC |
586 | package o { |
587 | use overload | |
588 | '""', sub { ++our $count; $_[0][0]; }, | |
589 | '0+', sub { ++our $numcount; $_[0][1]; } | |
590 | } | |
591 | my $o = bless ["\x{100}",42], o::; | |
667f6f15 FC |
592 | () = sprintf "%1s", $o; |
593 | is $o::count, '1', 'sprinf %1s overload count'; | |
594 | $o::count = 0; | |
595 | () = sprintf "%.1s", $o; | |
596 | is $o::count, '1', 'sprinf %.1s overload count'; | |
1d55083c FC |
597 | $o::count = 0; |
598 | () = sprintf "%d", $o; | |
599 | is $o::count, 0, 'sprintf %d string overload count is 0'; | |
600 | is $o::numcount, 1, 'sprintf %d number overload count is 1'; | |
40bca5ae | 601 | |
15899733 JH |
602 | SKIP: { # hexfp |
603 | if ($vax_float) { skip "VAX float no hexfp", scalar @hexfloat } | |
604 | ||
35ff3d7d JH |
605 | my $ppc_linux = $Config{archname} =~ /^(?:ppc|power(?:pc)?)(?:64)?-linux/; |
606 | my $irix_ld = $Config{archname} =~ /^IP\d+-irix-ld$/; | |
261d007a | 607 | |
40bca5ae JH |
608 | for my $t (@hexfloat) { |
609 | my ($format, $arg, $expected) = @$t; | |
610 | $arg = eval $arg; | |
611 | my $result = sprintf($format, $arg); | |
61b5c618 | 612 | my $ok = $result eq $expected; |
35ff3d7d JH |
613 | # For certain platforms (all of which are currently double-double, |
614 | # but different implementations, GNU vs vendor, two different archs | |
615 | # (ppc and mips), and two different libm interfaces) we have some | |
616 | # bits-in-the-last-hexdigit differences. | |
617 | # Patch them up as TODOs instead of deadly errors. | |
618 | if ($doubledouble && $ppc_linux && $arg =~ /^2.71828/) { | |
619 | # gets '0x1.5bf0a8b1457695355fb8ac404ecp+1' | |
620 | # wants '0x1.5bf0a8b1457695355fb8ac404e8p+1' | |
261d007a JH |
621 | local $::TODO = "$Config{archname} exp(1)"; |
622 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); | |
623 | next; | |
624 | } | |
ced634a4 | 625 | if ($doubledouble && $irix_ld && $arg =~ /^1.41421/) { |
ced634a4 JH |
626 | # gets '0x1.6a09e667f3bcc908b2fb1366eacp+0' |
627 | # wants '0x1.6a09e667f3bcc908b2fb1366ea8p+0' | |
628 | local $::TODO = "$Config{archname} sqrt(2)"; | |
629 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); | |
630 | next; | |
631 | } | |
dd164517 | 632 | if (!$ok && $result =~ /\./ && $expected =~ /\./) { |
61b5c618 JH |
633 | # It seems that there can be difference in the last bits: |
634 | # [perl #122578] | |
635 | # got "0x1.5bf0a8b14576ap+1" | |
636 | # expected "0x1.5bf0a8b145769p+1" | |
637 | # (Android on ARM) | |
638 | # | |
639 | # Exact cause unknown but suspecting different fp rounding modes, | |
640 | # (towards zero? towards +inf? towards -inf?) about which Perl | |
641 | # is blissfully unaware. | |
642 | # | |
643 | # Try extracting one (or sometimes two) last mantissa | |
644 | # hexdigits, and see if they differ in value by one. | |
645 | my ($rh, $eh) = ($result, $expected); | |
646 | sub extract_prefix { | |
13d235b3 | 647 | ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1; |
61b5c618 JH |
648 | } |
649 | my $rp = extract_prefix($rh); | |
650 | my $ep = extract_prefix($eh); | |
651 | print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n"; | |
652 | if ($rp eq $ep) { # If prefixes match. | |
653 | sub extract_exponent { | |
13d235b3 | 654 | ($_[0] =~ s/([pP][+-]?\d+)//) && return $1; |
61b5c618 JH |
655 | } |
656 | my $re = extract_exponent($rh); | |
657 | my $ee = extract_exponent($eh); | |
658 | print "# re = $re, ee = $ee (rh $rh, eh $eh)\n"; | |
659 | if ($re eq $ee) { # If exponents match. | |
660 | # Remove the common prefix of the mantissa bits. | |
661 | my $la = length($rh); | |
662 | my $lb = length($eh); | |
663 | my $i; | |
664 | for ($i = 0; $i < $la && $i < $lb; $i++) { | |
665 | last if substr($rh, $i, 1) ne substr($eh, $i, 1); | |
666 | } | |
667 | $rh = substr($rh, $i); | |
668 | $eh = substr($eh, $i); | |
669 | print "# (rh $rh, eh $eh)\n"; | |
670 | if ($rh ne $eh) { | |
671 | # If necessary, pad the shorter one on the right | |
672 | # with one zero (for example "...1f" vs "...2", | |
673 | # we want to compare "1f" to "20"). | |
674 | if (length $rh < length $eh) { | |
675 | $rh .= '0'; | |
676 | } elsif (length $eh < length $rh) { | |
677 | $eh .= '0'; | |
678 | } | |
679 | print "# (rh $rh, eh $eh)\n"; | |
680 | if (length $eh == length $rh) { | |
681 | if (abs(hex($eh) - hex($rh)) == 1) { | |
682 | $ok = 1; | |
683 | } | |
684 | } | |
685 | } | |
686 | } | |
687 | } | |
688 | } | |
689 | ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); | |
40bca5ae | 690 | } |
5488d373 | 691 | |
15899733 JH |
692 | } # SKIP: # hexfp |
693 | ||
5488d373 S |
694 | # double-double long double %a special testing. |
695 | SKIP: { | |
0b367b79 CB |
696 | skip("uselongdouble=" . ($Config{uselongdouble} ? 'define' : 'undef') |
697 | . " longdblkind=$Config{longdblkind} os=$^O", 6) | |
796fb084 JH |
698 | unless ($Config{uselongdouble} && |
699 | ($Config{longdblkind} == 5 || | |
700 | $Config{longdblkind} == 6) | |
1c273873 JH |
701 | # Gating on 'linux' (ppc) here is due to the differing |
702 | # double-double implementations: other (also big-endian) | |
703 | # double-double platforms (e.g. AIX on ppc or IRIX on mips) | |
704 | # do not behave similarly. | |
796fb084 JH |
705 | && $^O eq 'linux' |
706 | ); | |
5488d373 | 707 | # [rt.perl.org 125633] |
15899733 | 708 | like(sprintf("%La\n", eval '(2**1020) + (2**-1072)'), |
5488d373 | 709 | qr/^0x1.0{522}1p\+1020$/); |
15899733 | 710 | like(sprintf("%La\n", eval '(2**1021) + (2**-1072)'), |
5488d373 | 711 | qr/^0x1.0{523}8p\+1021$/); |
15899733 | 712 | like(sprintf("%La\n", eval '(2**1022) + (2**-1072)'), |
5488d373 | 713 | qr/^0x1.0{523}4p\+1022$/); |
15899733 | 714 | like(sprintf("%La\n", eval '(2**1023) + (2**-1072)'), |
5488d373 | 715 | qr/^0x1.0{523}2p\+1023$/); |
15899733 | 716 | like(sprintf("%La\n", eval '(2**1023) + (2**-1073)'), |
5488d373 | 717 | qr/^0x1.0{523}1p\+1023$/); |
15899733 | 718 | like(sprintf("%La\n", eval '(2**1023) + (2**-1074)'), |
5488d373 S |
719 | qr/^0x1.0{524}8p\+1023$/); |
720 | } | |
4755cf01 JH |
721 | |
722 | SKIP: { | |
798a7a50 | 723 | skip("negative zero not available\n", 3) |
4755cf01 JH |
724 | unless sprintf('%+f', -0.0) =~ /^-0/; |
725 | is(sprintf("%a", -0.0), "-0x0p+0", "negative zero"); | |
726 | is(sprintf("%+a", -0.0), "-0x0p+0", "negative zero"); | |
798a7a50 | 727 | is(sprintf("%.13a", -0.0), "-0x0.0000000000000p+0", "negative zero"); |
4755cf01 | 728 | } |
eba98284 JH |
729 | |
730 | SKIP: { | |
731 | # [perl #127183] Non-canonical hexadecimal floats are parsed prematurely | |
732 | ||
b6d9b423 | 733 | # IEEE 754 64-bit |
eba98284 JH |
734 | skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53", 3) |
735 | unless $Config{nv_preserves_uv_bits} == 53; | |
736 | ||
737 | { | |
738 | # The 0x0.b17217f7d1cf78p0 is the original LHS value | |
739 | # from [perl #127183], its bits are 0x162e42fefa39ef << 3, | |
740 | # resulting in a non-canonical form of hexfp, where the most | |
741 | # significant bit is zero, instead of one. | |
742 | is(sprintf("%a", 0x0.b17217f7d1cf78p0 - 0x1.62e42fefa39efp-1), | |
743 | "0x0p+0", | |
744 | "non-canonical form [perl #127183]"); | |
745 | } | |
746 | ||
747 | { | |
748 | no warnings 'overflow'; # Not the point here. | |
749 | ||
750 | # The 0x058b90bfbe8e7bc is 0x162e42fefa39ef << 2, | |
751 | # the 0x02c5c85fdf473de is 0x162e42fefa39ef << 1, | |
752 | # see above. | |
753 | is(sprintf("%a", 0x0.58b90bfbe8e7bcp1 - 0x1.62e42fefa39efp-1), | |
754 | "0x0p+0", | |
755 | "non-canonical form"); | |
756 | ||
757 | is(sprintf("%a", 0x0.2c5c85fdf473dep2 - 0x1.62e42fefa39efp-1), | |
758 | "0x0p+0", | |
759 | "non-canonical form"); | |
760 | } | |
761 | } | |
b6d9b423 | 762 | |
e3f7a67e JH |
763 | # These are IEEE 754 64-bit subnormals (formerly known as denormals). |
764 | # Keep these as strings so that non-IEEE-754 don't trip over them. | |
765 | my @subnormals = ( | |
766 | [ '1e-320', '%a', '0x1.fap-1064' ], | |
767 | [ '1e-321', '%a', '0x1.94p-1067' ], | |
768 | [ '1e-322', '%a', '0x1.4p-1070' ], | |
769 | [ '1e-323', '%a', '0x1p-1073' ], | |
770 | [ '1e-324', '%a', '0x0p+0' ], # underflow | |
771 | [ '3e-320', '%a', '0x1.7b8p-1062' ], | |
772 | [ '3e-321', '%a', '0x1.2f8p-1065' ], | |
773 | [ '3e-322', '%a', '0x1.e8p-1069' ], | |
774 | [ '3e-323', '%a', '0x1.8p-1072' ], | |
775 | [ '3e-324', '%a', '0x1p-1074' ], # the smallest possible value | |
776 | [ '7e-320', '%a', '0x1.bacp-1061' ], | |
777 | [ '7e-321', '%a', '0x1.624p-1064' ], | |
778 | [ '7e-322', '%a', '0x1.1cp-1067' ], | |
779 | [ '7e-323', '%a', '0x1.cp-1071' ], | |
780 | [ '7e-324', '%a', '0x1p-1074' ], # the smallest possible value, again | |
781 | [ '3e-320', '%.4a', '0x1.7b80p-1062' ], | |
782 | [ '3e-321', '%.4a', '0x1.2f80p-1065' ], | |
783 | [ '3e-322', '%.4a', '0x1.e800p-1069' ], | |
784 | [ '3e-323', '%.4a', '0x1.8000p-1072' ], | |
785 | [ '3e-324', '%.4a', '0x1.0000p-1074' ], | |
786 | [ '3e-320', '%.1a', '0x1.8p-1062' ], | |
787 | [ '3e-321', '%.1a', '0x1.3p-1065' ], | |
788 | [ '3e-322', '%.1a', '0x1.ep-1069' ], | |
789 | [ '3e-323', '%.1a', '0x1.8p-1072' ], | |
790 | [ '3e-324', '%.1a', '0x1.0p-1074' ], | |
f5a46661 JH |
791 | [ '0x1.fffffffffffffp-1022', '%a', '0x1.fffffffffffffp-1022' ], |
792 | [ '0x0.fffffffffffffp-1022', '%a', '0x1.ffffffffffffep-1023' ], | |
793 | [ '0x0.7ffffffffffffp-1022', '%a', '0x1.ffffffffffffcp-1024' ], | |
794 | [ '0x0.3ffffffffffffp-1022', '%a', '0x1.ffffffffffff8p-1025' ], | |
795 | [ '0x0.1ffffffffffffp-1022', '%a', '0x1.ffffffffffffp-1026' ], | |
796 | [ '0x0.0ffffffffffffp-1022', '%a', '0x1.fffffffffffep-1027' ], | |
e3f7a67e | 797 | ); |
b6d9b423 | 798 | |
e3f7a67e JH |
799 | SKIP: { |
800 | # [rt.perl.org #128843] | |
801 | skip("non-IEEE-754-non-64-bit", scalar @subnormals + 34) | |
802 | unless ($Config{nvsize} == 8 && | |
803 | $Config{nv_preserves_uv_bits} == 53 && | |
804 | ($Config{doublekind} == 3 || | |
805 | $Config{doublekind} == 4)); | |
b6d9b423 JH |
806 | |
807 | for my $t (@subnormals) { | |
f5a46661 JH |
808 | # Note that "0x1p+2" is not considered numeric, |
809 | # since neither is "0x12", hence the eval. | |
810 | my $s = sprintf($t->[1], eval $t->[0]); | |
b6d9b423 JH |
811 | is($s, $t->[2], "subnormal @$t got $s"); |
812 | } | |
82229f9f | 813 | |
749d8534 JH |
814 | # [rt.perl.org #128888] |
815 | is(sprintf("%a", 1.03125), "0x1.08p+0"); | |
816 | is(sprintf("%.1a", 1.03125), "0x1.0p+0"); | |
817 | is(sprintf("%.0a", 1.03125), "0x1p+0", "[rt.perl.org #128888]"); | |
818 | ||
e3f7a67e JH |
819 | # [rt.perl.org #128889] |
820 | is(sprintf("%.*a", -1, 1.03125), "0x1.08p+0", "[rt.perl.org #128889]"); | |
821 | ||
822 | # [rt.perl.org #128890] | |
823 | is(sprintf("%a", 0x1.18p+0), "0x1.18p+0"); | |
824 | is(sprintf("%.1a", 0x1.08p+0), "0x1.0p+0"); | |
825 | is(sprintf("%.1a", 0x1.18p+0), "0x1.2p+0", "[rt.perl.org #128890]"); | |
826 | is(sprintf("%.1a", 0x1.28p+0), "0x1.2p+0"); | |
827 | is(sprintf("%.1a", 0x1.38p+0), "0x1.4p+0"); | |
828 | is(sprintf("%.1a", 0x1.48p+0), "0x1.4p+0"); | |
829 | is(sprintf("%.1a", 0x1.58p+0), "0x1.6p+0"); | |
830 | is(sprintf("%.1a", 0x1.68p+0), "0x1.6p+0"); | |
831 | is(sprintf("%.1a", 0x1.78p+0), "0x1.8p+0"); | |
832 | is(sprintf("%.1a", 0x1.88p+0), "0x1.8p+0"); | |
833 | is(sprintf("%.1a", 0x1.98p+0), "0x1.ap+0"); | |
834 | is(sprintf("%.1a", 0x1.a8p+0), "0x1.ap+0"); | |
835 | is(sprintf("%.1a", 0x1.b8p+0), "0x1.cp+0"); | |
836 | is(sprintf("%.1a", 0x1.c8p+0), "0x1.cp+0"); | |
837 | is(sprintf("%.1a", 0x1.d8p+0), "0x1.ep+0"); | |
838 | is(sprintf("%.1a", 0x1.e8p+0), "0x1.ep+0"); | |
839 | is(sprintf("%.1a", 0x1.f8p+0), "0x2.0p+0"); | |
840 | ||
841 | is(sprintf("%.1a", 0x1.10p+0), "0x1.1p+0"); | |
842 | is(sprintf("%.1a", 0x1.17p+0), "0x1.1p+0"); | |
843 | is(sprintf("%.1a", 0x1.19p+0), "0x1.2p+0"); | |
844 | is(sprintf("%.1a", 0x1.1fp+0), "0x1.2p+0"); | |
845 | ||
846 | is(sprintf("%.2a", 0x1.fffp+0), "0x2.00p+0"); | |
847 | is(sprintf("%.2a", 0xf.fffp+0), "0x2.00p+3"); | |
848 | ||
849 | # [rt.perl.org #128893] | |
850 | is(sprintf("%020a", 1.5), "0x0000000000001.8p+0"); | |
851 | is(sprintf("%020a", -1.5), "-0x000000000001.8p+0", "[rt.perl.org #128893]"); | |
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("%20a", -1.5), " -0x1.8p+0"); | |
855 | is(sprintf("%+20a", 1.5), " +0x1.8p+0"); | |
856 | is(sprintf("% 20a", 1.5), " 0x1.8p+0"); | |
749d8534 | 857 | } |
e3f7a67e JH |
858 | |
859 | # x86 80-bit long-double tests for | |
ee58923a | 860 | # rt.perl.org #128843, #128888, #128889, #128890, #128893, #128909 |
e3f7a67e | 861 | SKIP: { |
f40ac91c | 862 | skip("non-80-bit-long-double", 17) |
e3f7a67e JH |
863 | unless ($Config{uselongdouble} && |
864 | ($Config{nvsize} == 16 || $Config{nvsize} == 12) && | |
865 | ($Config{longdblkind} == 3 || | |
866 | $Config{longdblkind} == 4)); | |
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 |
898 | SKIP: { | |
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 | ||
e3f7a67e | 917 | done_testing(); |