Commit | Line | Data |
---|---|---|
9c6df44e NT |
1 | #!./perl |
2 | BEGIN { | |
3 | chdir 't' if -d 't'; | |
4 | @INC = '../lib'; | |
5 | require './test.pl'; # for fresh_perl_is() etc | |
a5dfa8d3 | 6 | require './loc_tools.pl'; # to find locales |
9c6df44e NT |
7 | } |
8 | ||
9 | use strict; | |
10 | ||
11 | ######## | |
903eb63f | 12 | # These tests are here instead of lib/locale.t because |
05760874 | 13 | # some bugs depend on the internal state of the locale |
9c6df44e | 14 | # settings and pragma/locale messes up that state pretty badly. |
903eb63f | 15 | # We need "fresh runs". |
9c6df44e | 16 | BEGIN { |
903eb63f | 17 | eval { require POSIX; POSIX->import("locale_h") }; |
9c6df44e NT |
18 | if ($@) { |
19 | skip_all("could not load the POSIX module"); # running minitest? | |
20 | } | |
21 | } | |
22 | use Config; | |
371d5d44 | 23 | my $have_strtod = $Config{d_strtod} eq 'define'; |
cd1f7080 | 24 | my @locales = find_locales( [ 'LC_ALL', 'LC_CTYPE', 'LC_NUMERIC' ]); |
9c6df44e NT |
25 | skip_all("no locales available") unless @locales; |
26 | ||
c53481e7 | 27 | # reset the locale environment |
f7d258b8 | 28 | delete local @ENV{'LANG', (grep /^LC_/, keys %ENV)}; |
c53481e7 | 29 | |
9c6df44e | 30 | plan tests => &last; |
49efabc8 | 31 | |
a7fa5053 | 32 | my $non_C_locale; |
49efabc8 | 33 | foreach my $locale (@locales) { |
a7fa5053 KW |
34 | next if $locale eq "C" || $locale eq 'POSIX'; |
35 | $non_C_locale = $locale; | |
49efabc8 KW |
36 | last; |
37 | } | |
38 | ||
a7fa5053 KW |
39 | SKIP: { |
40 | skip("no non-C locale available", 2 ) unless $non_C_locale; | |
41 | setlocale(LC_NUMERIC, $non_C_locale); | |
42 | isnt(setlocale(LC_NUMERIC), "C", "retrieving current non-C LC_NUMERIC doesn't give 'C'"); | |
43 | setlocale(LC_ALL, $non_C_locale); | |
44 | isnt(setlocale(LC_ALL), "C", "retrieving current non-C LC_ALL doesn't give 'C'"); | |
45 | } | |
46 | ||
dc51aebe KW |
47 | # Skip this locale on these cywgwin versions as the returned radix character |
48 | # length is wrong | |
49 | my @test_numeric_locales = ($^O ne 'cygwin' || version->new(($Config{'osvers'} =~ /^(\d+(?:\.\d+)+)/)[0]) gt v2.4.1) | |
50 | ? @locales | |
51 | : grep { $_ !~ m/ps_AF/i } @locales; | |
52 | ||
53 | fresh_perl_is("for (qw(@test_numeric_locales)) {\n" . <<'EOF', | |
9c6df44e NT |
54 | use POSIX qw(locale_h); |
55 | use locale; | |
56 | setlocale(LC_NUMERIC, "$_") or next; | |
57 | my $s = sprintf "%g %g", 3.1, 3.1; | |
58 | next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; | |
59 | print "$_ $s\n"; | |
60 | } | |
61 | EOF | |
62 | "", {}, "no locales where LC_NUMERIC breaks"); | |
63 | ||
e1df4071 | 64 | SKIP: { |
2ebcba0a | 65 | skip("Windows stores locale defaults in the registry", 1 ) |
e1df4071 | 66 | if $^O eq 'MSWin32'; |
5be9e824 KW |
67 | fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF', |
68 | use POSIX qw(locale_h); | |
69 | use locale; | |
70 | my $in = 4.2; | |
71 | my $s = sprintf "%g", $in; # avoid any constant folding bugs | |
72 | next if $s eq "4.2"; | |
73 | print "$_ $s\n"; | |
74 | } | |
903eb63f | 75 | EOF |
bc8ec7cc KW |
76 | "", {}, "LC_NUMERIC without environment nor setlocale() has no effect in any locale"); |
77 | } | |
8d0b139e | 78 | |
903eb63f NT |
79 | # try to find out a locale where LC_NUMERIC makes a difference |
80 | my $original_locale = setlocale(LC_NUMERIC); | |
81 | ||
c1284011 KW |
82 | my ($base, $different, $comma, $difference, $utf8_radix); |
83 | my $radix_encoded_as_utf8; | |
903eb63f | 84 | for ("C", @locales) { # prefer C for the base if available |
5f1269ab | 85 | use locale; |
903eb63f NT |
86 | setlocale(LC_NUMERIC, $_) or next; |
87 | my $in = 4.2; # avoid any constant folding bugs | |
88 | if ((my $s = sprintf("%g", $in)) eq "4.2") { | |
89 | $base ||= $_; | |
90 | } else { | |
91 | $different ||= $_; | |
92 | $difference ||= $s; | |
c1284011 KW |
93 | my $radix = localeconv()->{decimal_point}; |
94 | ||
95 | # For utf8 locales with a non-ascii radix, it should be encoded as | |
96 | # UTF-8 with the internal flag so set. | |
97 | if (! defined $utf8_radix | |
98 | && $radix =~ /[[:^ascii:]]/ | |
99 | && is_locale_utf8($_)) | |
100 | { | |
101 | $utf8_radix = $_; | |
102 | $radix_encoded_as_utf8 = utf8::is_utf8($radix); | |
103 | } | |
104 | else { | |
105 | $comma ||= $_ if $radix eq ','; | |
106 | } | |
903eb63f NT |
107 | } |
108 | ||
c1284011 | 109 | last if $base && $different && $comma && $utf8_radix; |
903eb63f NT |
110 | } |
111 | setlocale(LC_NUMERIC, $original_locale); | |
112 | ||
113 | SKIP: { | |
c1284011 KW |
114 | skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 ) |
115 | unless $utf8_radix; | |
116 | ok($radix_encoded_as_utf8 == 1, "UTF-8 locale '$utf8_radix' with non-ASCII" | |
117 | . " radix is marked UTF-8"); | |
118 | } | |
119 | ||
120 | SKIP: { | |
a7fa5053 KW |
121 | skip("no locale available where LC_NUMERIC makes a difference", &last - 7 ) |
122 | if !$different; # -7 is 5 tests before this block; 2 after | |
903eb63f | 123 | note("using the '$different' locale for LC_NUMERIC tests"); |
0ba5b45d KW |
124 | { |
125 | local $ENV{LC_NUMERIC} = $different; | |
903eb63f NT |
126 | |
127 | fresh_perl_is(<<'EOF', "4.2", {}, | |
128 | format STDOUT = | |
129 | @.# | |
130 | 4.179 | |
131 | . | |
132 | write; | |
133 | EOF | |
134 | "format() does not look at LC_NUMERIC without 'use locale'"); | |
135 | ||
136 | { | |
d6ded950 KW |
137 | fresh_perl_is(<<'EOF', "$difference\n", {}, |
138 | use POSIX; | |
903eb63f NT |
139 | use locale; |
140 | format STDOUT = | |
141 | @.# | |
142 | 4.179 | |
143 | . | |
144 | write; | |
145 | EOF | |
146 | "format() looks at LC_NUMERIC with 'use locale'"); | |
147 | } | |
148 | ||
149 | { | |
a835cd47 KW |
150 | fresh_perl_is(<<'EOF', ",,", {}, |
151 | print localeconv()->{decimal_point}; | |
152 | use POSIX; | |
153 | use locale; | |
154 | print localeconv()->{decimal_point}; | |
155 | EOF | |
156 | "localeconv() looks at LC_NUMERIC with and without 'use locale'"); | |
157 | } | |
158 | ||
159 | { | |
d6ded950 KW |
160 | my $categories = ":collate :characters :collate :ctype :monetary :time"; |
161 | fresh_perl_is(<<"EOF", "4.2", {}, | |
162 | use locale qw($categories); | |
163 | format STDOUT = | |
164 | @.# | |
165 | 4.179 | |
166 | . | |
167 | write; | |
168 | EOF | |
169 | "format() does not look at LC_NUMERIC with 'use locale qw($categories)'"); | |
170 | } | |
171 | ||
172 | { | |
173 | fresh_perl_is(<<'EOF', $difference, {}, | |
174 | use locale; | |
175 | format STDOUT = | |
176 | @.# | |
177 | 4.179 | |
178 | . | |
179 | write; | |
180 | EOF | |
181 | "format() looks at LC_NUMERIC with 'use locale'"); | |
182 | } | |
183 | ||
184 | for my $category (qw(collate characters collate ctype monetary time)) { | |
185 | for my $negation ("!", "not_") { | |
186 | fresh_perl_is(<<"EOF", $difference, {}, | |
187 | use locale ":$negation$category"; | |
188 | format STDOUT = | |
189 | @.# | |
190 | 4.179 | |
191 | . | |
192 | write; | |
193 | EOF | |
194 | "format() looks at LC_NUMERIC with 'use locale \":" | |
195 | . "$negation$category\"'"); | |
196 | } | |
197 | } | |
198 | ||
199 | { | |
b34856cb | 200 | fresh_perl_is(<<'EOF', $difference, {}, |
d6ded950 | 201 | use locale ":numeric"; |
b34856cb KW |
202 | format STDOUT = |
203 | @.# | |
204 | 4.179 | |
205 | . | |
206 | write; | |
207 | EOF | |
d6ded950 | 208 | "format() looks at LC_NUMERIC with 'use locale \":numeric\"'"); |
b34856cb KW |
209 | } |
210 | ||
211 | { | |
903eb63f NT |
212 | fresh_perl_is(<<'EOF', "4.2", {}, |
213 | format STDOUT = | |
214 | @.# | |
215 | 4.179 | |
216 | . | |
5f1269ab | 217 | { use locale; write; } |
903eb63f NT |
218 | EOF |
219 | "too late to look at the locale at write() time"); | |
220 | } | |
221 | ||
222 | { | |
223 | fresh_perl_is(<<'EOF', $difference, {}, | |
569f7fc5 JR |
224 | use locale; |
225 | format STDOUT = | |
903eb63f NT |
226 | @.# |
227 | 4.179 | |
228 | . | |
229 | { no locale; write; } | |
230 | EOF | |
231 | "too late to ignore the locale at write() time"); | |
232 | } | |
233 | } | |
b3fd6149 | 234 | |
8d0b139e RS |
235 | { |
236 | # do not let "use 5.000" affect the locale! | |
237 | # this test is to prevent regression of [rt.perl.org #105784] | |
238 | fresh_perl_is(<<"EOF", | |
5f1269ab | 239 | use locale; |
8d0b139e RS |
240 | use POSIX; |
241 | my \$i = 0.123; | |
242 | POSIX::setlocale(POSIX::LC_NUMERIC(),"$different"); | |
243 | \$a = sprintf("%.2f", \$i); | |
244 | require version; | |
245 | \$b = sprintf("%.2f", \$i); | |
246 | print ".\$a \$b" unless \$a eq \$b | |
247 | EOF | |
248 | "", {}, "version does not clobber version"); | |
249 | ||
250 | fresh_perl_is(<<"EOF", | |
251 | use locale; | |
252 | use POSIX; | |
253 | my \$i = 0.123; | |
254 | POSIX::setlocale(POSIX::LC_NUMERIC(),"$different"); | |
255 | \$a = sprintf("%.2f", \$i); | |
256 | eval "use v5.0.0"; | |
257 | \$b = sprintf("%.2f", \$i); | |
258 | print "\$a \$b" unless \$a eq \$b | |
259 | EOF | |
260 | "", {}, "version does not clobber version (via eval)"); | |
261 | } | |
262 | ||
0ba5b45d KW |
263 | { |
264 | local $ENV{LC_NUMERIC} = $different; | |
b3fd6149 | 265 | fresh_perl_is(<<'EOF', "$difference "x4, {}, |
6a188f46 | 266 | use locale; |
b3fd6149 | 267 | use POSIX qw(locale_h); |
b3fd6149 NT |
268 | my $in = 4.2; |
269 | printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2)); | |
270 | EOF | |
271 | "sprintf() and printf() look at LC_NUMERIC regardless of constant folding"); | |
272 | } | |
02aba72f | 273 | |
0ba5b45d KW |
274 | { |
275 | local $ENV{LC_NUMERIC} = $different; | |
481465ea KW |
276 | fresh_perl_is(<<'EOF', "$difference "x4, {}, |
277 | use locale; | |
278 | use POSIX qw(locale_h); | |
481465ea KW |
279 | my $in = 4.2; |
280 | printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2)); | |
281 | EOF | |
282 | "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC"); | |
283 | } | |
284 | ||
ff4377fe DM |
285 | |
286 | # within this block, STDERR is closed. This is because fresh_perl_is() | |
287 | # forks a shell, and some shells (like bash) can complain noisily when | |
1da50240 | 288 | # LC_ALL or similar is set to an invalid value |
ff4377fe DM |
289 | |
290 | { | |
291 | open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!"; | |
292 | close STDERR; | |
293 | ||
0ba5b45d | 294 | { |
250680e3 DM |
295 | local $ENV{LC_ALL} = "invalid"; |
296 | local $ENV{LC_NUMERIC} = "invalid"; | |
0ba5b45d | 297 | local $ENV{LANG} = $different; |
62fe37a7 | 298 | local $ENV{PERL_BADLANG} = 0; |
65ebb059 | 299 | |
62fe37a7 | 300 | if (! fresh_perl_is(<<"EOF", "$difference", { }, |
e9a5eef6 KW |
301 | if (\$ENV{LC_ALL} ne "invalid") { |
302 | # Make the test pass if the sh didn't accept the ENV set | |
303 | print "$difference\n"; | |
304 | exit 0; | |
305 | } | |
250680e3 DM |
306 | use locale; |
307 | use POSIX qw(locale_h); | |
e9a5eef6 KW |
308 | my \$in = 4.2; |
309 | printf("%g", \$in); | |
65ebb059 | 310 | EOF |
10225cc4 KW |
311 | "LANG is used if LC_ALL, LC_NUMERIC are invalid")) |
312 | { | |
6d04d1e9 | 313 | note "To see details change this .t, do not close STDERR"; |
10225cc4 | 314 | } |
65ebb059 | 315 | } |
65ebb059 | 316 | |
250680e3 DM |
317 | SKIP: { |
318 | if ($^O eq 'MSWin32') { | |
319 | skip("Win32 uses system default locale in preference to \"C\"", | |
320 | 1); | |
321 | } | |
322 | else { | |
68021d02 KW |
323 | local $ENV{LC_ALL} = "invalid"; |
324 | local $ENV{LC_NUMERIC} = "invalid"; | |
325 | local $ENV{LANG} = "invalid"; | |
62fe37a7 | 326 | local $ENV{PERL_BADLANG} = 0; |
250680e3 | 327 | |
62fe37a7 | 328 | if (! fresh_perl_is(<<"EOF", 4.2, { }, |
68021d02 KW |
329 | if (\$ENV{LC_ALL} ne "invalid") { |
330 | print "$difference\n"; | |
331 | exit 0; | |
332 | } | |
333 | use locale; | |
334 | use POSIX qw(locale_h); | |
68021d02 KW |
335 | my \$in = 4.2; |
336 | printf("%g", \$in); | |
65ebb059 | 337 | EOF |
10225cc4 KW |
338 | 'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid')) |
339 | { | |
6d04d1e9 | 340 | note "To see details change this .t, do not close STDERR"; |
10225cc4 | 341 | } |
65ebb059 KW |
342 | } |
343 | } | |
65ebb059 | 344 | |
ff4377fe DM |
345 | open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!"; |
346 | } | |
347 | ||
0ba5b45d KW |
348 | { |
349 | local $ENV{LC_NUMERIC} = $different; | |
bc8ec7cc KW |
350 | fresh_perl_is(<<"EOF", |
351 | use POSIX qw(locale_h); | |
352 | ||
0ba5b45d | 353 | BEGIN { setlocale(LC_NUMERIC, \"$different\"); }; |
bc8ec7cc KW |
354 | setlocale(LC_ALL, "C"); |
355 | use 5.008; | |
356 | print setlocale(LC_NUMERIC); | |
357 | EOF | |
cd0b934e | 358 | "C", { stderr => 'devnull' }, |
bc8ec7cc KW |
359 | "No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix"); |
360 | } | |
361 | ||
02aba72f | 362 | unless ($comma) { |
65ebb059 | 363 | skip("no locale available where LC_NUMERIC is a comma", 3); |
02aba72f KW |
364 | } |
365 | else { | |
366 | ||
367 | fresh_perl_is(<<"EOF", | |
368 | my \$i = 1.5; | |
369 | { | |
370 | use locale; | |
371 | use POSIX; | |
372 | POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma"); | |
373 | print \$i, "\n"; | |
374 | } | |
375 | print \$i, "\n"; | |
376 | EOF | |
cd0b934e | 377 | "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without"); |
02aba72f KW |
378 | |
379 | fresh_perl_is(<<"EOF", | |
380 | my \$i = 1.5; # Should be exactly representable as a base 2 | |
381 | # fraction, so can use 'eq' below | |
382 | use locale; | |
383 | use POSIX; | |
384 | POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma"); | |
385 | print \$i, "\n"; | |
386 | \$i += 1; | |
387 | print \$i, "\n"; | |
388 | EOF | |
cd0b934e | 389 | "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800] |
371d5d44 KW |
390 | |
391 | unless ($have_strtod) { | |
392 | skip("no strtod()", 1); | |
393 | } | |
394 | else { | |
395 | fresh_perl_is(<<"EOF", | |
396 | use POSIX; | |
397 | POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma"); | |
398 | my \$one_point_5 = POSIX::strtod("1,5"); | |
399 | \$one_point_5 =~ s/0+\$//; # Remove any trailing zeros | |
400 | print \$one_point_5, "\n"; | |
401 | EOF | |
cd0b934e | 402 | "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale"); |
371d5d44 | 403 | } |
02aba72f | 404 | } |
11220351 | 405 | } # SKIP |
02aba72f | 406 | |
ee48a02a KW |
407 | { |
408 | fresh_perl_is(<<"EOF", | |
409 | use locale; | |
410 | use POSIX; | |
411 | POSIX::setlocale(POSIX::LC_CTYPE(),"C"); | |
412 | print "h" =~ /[g\\w]/i || 0; | |
413 | print "\\n"; | |
414 | EOF | |
cd0b934e | 415 | 1, { stderr => 'devnull' }, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char"); |
ee48a02a KW |
416 | } |
417 | ||
6e79ab66 KW |
418 | { |
419 | fresh_perl_is(<<"EOF", | |
420 | use locale; | |
421 | use POSIX; | |
422 | POSIX::setlocale(POSIX::LC_CTYPE(),"C"); | |
423 | print "0" =~ /[\\d[:punct:]]/l || 0; | |
424 | print "\\n"; | |
425 | EOF | |
cd0b934e | 426 | 1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class"); |
6e79ab66 KW |
427 | |
428 | } | |
429 | ||
a7fa5053 KW |
430 | # IMPORTANT: When adding tests before the following line, be sure to update |
431 | # its skip count: | |
432 | # skip("no locale available where LC_NUMERIC makes a difference", ...) | |
49efabc8 | 433 | sub last { 37 } |