This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/run/locale.t: use 'warnings'
[perl5.git] / t / run / locale.t
CommitLineData
9c6df44e
NT
1#!./perl
2BEGIN {
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
9use strict;
ef536431 10use warnings;
9c6df44e
NT
11
12########
903eb63f 13# These tests are here instead of lib/locale.t because
05760874 14# some bugs depend on the internal state of the locale
9c6df44e 15# settings and pragma/locale messes up that state pretty badly.
903eb63f 16# We need "fresh runs".
9c6df44e 17BEGIN {
903eb63f 18 eval { require POSIX; POSIX->import("locale_h") };
9c6df44e
NT
19 if ($@) {
20 skip_all("could not load the POSIX module"); # running minitest?
21 }
22}
23use Config;
371d5d44 24my $have_strtod = $Config{d_strtod} eq 'define';
cd1f7080 25my @locales = find_locales( [ 'LC_ALL', 'LC_CTYPE', 'LC_NUMERIC' ]);
9c6df44e 26skip_all("no locales available") unless @locales;
238fb9b3 27note("locales available: @locales");
9c6df44e 28
40f10af4
KW
29my $debug = 0;
30my $switches = "";
31if (defined $ARGV[0] && $ARGV[0] ne "") {
32 if ($ARGV[0] ne 'debug') {
33 print STDERR "Usage: $0 [ debug ]\n";
34 exit 1
35 }
36 $debug = 1;
37 $switches = "switches => [ '-DLv' ]";
38}
39
c53481e7 40# reset the locale environment
d5e32b93 41delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
c53481e7 42
40f10af4
KW
43# If user wants this to happen, they set the environment variable AND use
44# 'debug'
45delete local $ENV{'PERL_DEBUG_LOCALE_INIT'} unless $debug;
46
385130eb
KW
47{
48 fresh_perl_is(<<"EOF",
49 use locale;
50 use POSIX;
51 POSIX::setlocale(POSIX::LC_CTYPE(),"C");
52 print "h" =~ /[g\\w]/i || 0;
53 print "\\n";
54EOF
55 1, { stderr => 'devnull' }, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char");
56}
57
58{
59 fresh_perl_is(<<"EOF",
60 use locale;
61 use POSIX;
62 POSIX::setlocale(POSIX::LC_CTYPE(),"C");
63 print "0" =~ /[\\d[:punct:]]/l || 0;
64 print "\\n";
65EOF
66 1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class");
67
68}
49efabc8 69
a7fa5053 70my $non_C_locale;
49efabc8 71foreach my $locale (@locales) {
8e13243a 72 next if $locale eq "C" || $locale eq 'POSIX' || $locale eq "C.UTF-8";
a7fa5053 73 $non_C_locale = $locale;
49efabc8
KW
74 last;
75}
76
385130eb 77if ($non_C_locale) {
238fb9b3 78 note("using non-C locale '$non_C_locale'");
a7fa5053
KW
79 setlocale(LC_NUMERIC, $non_C_locale);
80 isnt(setlocale(LC_NUMERIC), "C", "retrieving current non-C LC_NUMERIC doesn't give 'C'");
81 setlocale(LC_ALL, $non_C_locale);
82 isnt(setlocale(LC_ALL), "C", "retrieving current non-C LC_ALL doesn't give 'C'");
a7fa5053 83
385130eb 84 my @test_numeric_locales = @locales;
dc51aebe 85
238fb9b3 86 # Skip this locale on these cygwin versions as the returned radix character
385130eb
KW
87 # length is wrong
88 if ( $^O eq 'cygwin'
89 && version->new(($Config{'osvers'} =~ /^(\d+(?:\.\d+)+)/)[0]) le v2.4.1)
90 {
91 @test_numeric_locales = grep { $_ !~ m/ps_AF/i } @test_numeric_locales;
92 }
9c6df44e 93
e3e8c0d6
KW
94 # Similarly the arabic locales on solaris don't work right on the
95 # multi-byte radix character, generating malformed UTF-8.
96 if ($^O eq 'solaris') {
97 @test_numeric_locales = grep { $_ !~ m/ ^ ( ar_ | pa_ ) /x }
98 @test_numeric_locales;
99 }
100
385130eb 101 fresh_perl_is("for (qw(@test_numeric_locales)) {\n" . <<'EOF',
5be9e824
KW
102 use POSIX qw(locale_h);
103 use locale;
385130eb
KW
104 setlocale(LC_NUMERIC, "$_") or next;
105 my $s = sprintf "%g %g", 3.1, 3.1;
106 next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
6ec573cf 107 no warnings "utf8";
5be9e824
KW
108 print "$_ $s\n";
109 }
903eb63f 110EOF
385130eb 111 "", { eval $switches }, "no locales where LC_NUMERIC breaks");
903eb63f 112
385130eb
KW
113 SKIP: {
114 skip("Windows stores locale defaults in the registry", 1 )
115 if $^O eq 'MSWin32';
116 fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF',
117 use POSIX qw(locale_h);
118 use locale;
119 my $in = 4.2;
120 my $s = sprintf "%g", $in; # avoid any constant folding bugs
121 next if $s eq "4.2";
6ec573cf 122 no warnings "utf8";
385130eb 123 print "$_ $s\n";
c1284011 124 }
385130eb
KW
125EOF
126 "", { eval $switches }, "LC_NUMERIC without environment nor setlocale() has no effect in any locale");
903eb63f
NT
127 }
128
385130eb
KW
129 # try to find out a locale where LC_NUMERIC makes a difference
130 my $original_locale = setlocale(LC_NUMERIC);
903eb63f 131
385130eb
KW
132 my ($base, $different, $comma, $difference, $utf8_radix);
133 my $radix_encoded_as_utf8;
134 for ("C", @locales) { # prefer C for the base if available
135 use locale;
136 setlocale(LC_NUMERIC, $_) or next;
137 my $in = 4.2; # avoid any constant folding bugs
138 if ((my $s = sprintf("%g", $in)) eq "4.2") {
139 $base ||= $_;
140 } else {
141 $different ||= $_;
142 $difference ||= $s;
143 my $radix = localeconv()->{decimal_point};
144
145 # For utf8 locales with a non-ascii radix, it should be encoded as
146 # UTF-8 with the internal flag so set.
147 if (! defined $utf8_radix
8dcd53c9 148 && $radix =~ /[[:^ascii:]]/u # /u because /l can raise warnings
385130eb
KW
149 && is_locale_utf8($_))
150 {
151 $utf8_radix = $_;
152 $radix_encoded_as_utf8 = utf8::is_utf8($radix);
153 }
154 else {
155 $comma ||= $_ if $radix eq ',';
156 }
157 }
c1284011 158
385130eb
KW
159 last if $base && $different && $comma && $utf8_radix;
160 }
161 setlocale(LC_NUMERIC, $original_locale);
903eb63f 162
385130eb
KW
163 SKIP: {
164 skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 )
165 unless $utf8_radix;
166 ok($radix_encoded_as_utf8 == 1, "UTF-8 locale '$utf8_radix' with non-ASCII"
167 . " radix is marked UTF-8");
168 }
169
46814e9b
JK
170 SKIP: {
171 skip("no locale available where LC_NUMERIC radix isn't '.'", 30) unless $different;
385130eb
KW
172 note("using the '$different' locale for LC_NUMERIC tests");
173 {
174 local $ENV{LC_NUMERIC} = $different;
175
176 fresh_perl_is(<<'EOF', "4.2", { eval $switches },
177 format STDOUT =
903eb63f
NT
178@.#
1794.179
180.
385130eb 181 write;
903eb63f 182EOF
385130eb 183 "format() does not look at LC_NUMERIC without 'use locale'");
903eb63f 184
385130eb
KW
185 {
186 fresh_perl_is(<<'EOF', "$difference\n", { eval $switches },
187 use POSIX;
188 use locale;
189 format STDOUT =
903eb63f
NT
190@.#
1914.179
192.
385130eb 193 write;
903eb63f 194EOF
385130eb
KW
195 "format() looks at LC_NUMERIC with 'use locale'");
196 }
903eb63f 197
385130eb
KW
198 {
199 fresh_perl_is(<<'EOF', ",,", { eval $switches },
200 use POSIX;
6ec573cf 201 no warnings "utf8";
385130eb
KW
202 print localeconv()->{decimal_point};
203 use locale;
204 print localeconv()->{decimal_point};
a835cd47 205EOF
385130eb
KW
206 "localeconv() looks at LC_NUMERIC with and without 'use locale'");
207 }
a835cd47 208
385130eb
KW
209 {
210 my $categories = ":collate :characters :collate :ctype :monetary :time";
211 fresh_perl_is(<<"EOF", "4.2", { eval $switches },
212 use locale qw($categories);
213 format STDOUT =
d6ded950
KW
214@.#
2154.179
216.
385130eb 217 write;
d6ded950 218EOF
385130eb
KW
219 "format() does not look at LC_NUMERIC with 'use locale qw($categories)'");
220 }
d6ded950 221
385130eb
KW
222 {
223 fresh_perl_is(<<'EOF', $difference, { eval $switches },
224 use locale;
225 format STDOUT =
d6ded950
KW
226@.#
2274.179
228.
385130eb 229 write;
d6ded950 230EOF
385130eb
KW
231 "format() looks at LC_NUMERIC with 'use locale'");
232 }
d6ded950 233
385130eb
KW
234 for my $category (qw(collate characters collate ctype monetary time)) {
235 for my $negation ("!", "not_") {
236 fresh_perl_is(<<"EOF", $difference, { eval $switches },
237 use locale ":$negation$category";
d6ded950
KW
238format STDOUT =
239@.#
2404.179
241.
385130eb 242 write;
d6ded950 243EOF
385130eb
KW
244 "format() looks at LC_NUMERIC with 'use locale \":"
245 . "$negation$category\"'");
246 }
d6ded950 247 }
d6ded950 248
385130eb
KW
249 {
250 fresh_perl_is(<<'EOF', $difference, { eval $switches },
251 use locale ":numeric";
b34856cb
KW
252format STDOUT =
253@.#
2544.179
255.
385130eb 256 write;
b34856cb 257EOF
385130eb
KW
258 "format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
259 }
b34856cb 260
385130eb
KW
261 {
262 fresh_perl_is(<<'EOF', "4.2", { eval $switches },
903eb63f
NT
263format STDOUT =
264@.#
2654.179
266.
385130eb 267 { use locale; write; }
903eb63f 268EOF
385130eb
KW
269 "too late to look at the locale at write() time");
270 }
903eb63f 271
385130eb
KW
272 {
273 fresh_perl_is(<<'EOF', $difference, { eval $switches },
274 use locale;
275 format STDOUT =
903eb63f
NT
276@.#
2774.179
278.
385130eb 279 { no locale; write; }
903eb63f 280EOF
385130eb
KW
281 "too late to ignore the locale at write() time");
282 }
903eb63f 283 }
8d0b139e 284
385130eb
KW
285 {
286 # do not let "use 5.000" affect the locale!
287 # this test is to prevent regression of [rt.perl.org #105784]
288 fresh_perl_is(<<"EOF",
289 use locale;
290 use POSIX;
291 my \$i = 0.123;
292 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
293 \$a = sprintf("%.2f", \$i);
294 require version;
295 \$b = sprintf("%.2f", \$i);
6ec573cf 296 no warnings "utf8";
385130eb 297 print ".\$a \$b" unless \$a eq \$b
8d0b139e 298EOF
385130eb 299 "", { eval $switches }, "version does not clobber version");
8d0b139e 300
385130eb
KW
301 fresh_perl_is(<<"EOF",
302 use locale;
303 use POSIX;
304 my \$i = 0.123;
305 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
306 \$a = sprintf("%.2f", \$i);
307 eval "use v5.0.0";
308 \$b = sprintf("%.2f", \$i);
6ec573cf 309 no warnings "utf8";
385130eb 310 print "\$a \$b" unless \$a eq \$b
b3fd6149 311EOF
385130eb
KW
312 "", { eval $switches }, "version does not clobber version (via eval)");
313 }
02aba72f 314
385130eb
KW
315 {
316 local $ENV{LC_NUMERIC} = $different;
317 fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
318 use locale;
319 use POSIX qw(locale_h);
320 my $in = 4.2;
321 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
481465ea 322EOF
385130eb
KW
323 "sprintf() and printf() look at LC_NUMERIC regardless of constant folding");
324 }
ff4377fe 325
0ba5b45d 326 {
385130eb
KW
327 local $ENV{LC_NUMERIC} = $different;
328 fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
250680e3
DM
329 use locale;
330 use POSIX qw(locale_h);
385130eb
KW
331 my $in = 4.2;
332 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
65ebb059 333EOF
385130eb 334 "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC");
65ebb059 335 }
65ebb059 336
385130eb
KW
337
338 # within this block, STDERR is closed. This is because fresh_perl_is()
339 # forks a shell, and some shells (like bash) can complain noisily when
340 # LC_ALL or similar is set to an invalid value
341
342 {
343 open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!";
344 close STDERR;
345
346 {
68021d02
KW
347 local $ENV{LC_ALL} = "invalid";
348 local $ENV{LC_NUMERIC} = "invalid";
385130eb 349 local $ENV{LANG} = $different;
62fe37a7 350 local $ENV{PERL_BADLANG} = 0;
250680e3 351
385130eb 352 if (! fresh_perl_is(<<"EOF", "$difference", { eval $switches },
68021d02 353 if (\$ENV{LC_ALL} ne "invalid") {
385130eb 354 # Make the test pass if the sh didn't accept the ENV set
6ec573cf 355 no warnings "utf8";
68021d02
KW
356 print "$difference\n";
357 exit 0;
358 }
359 use locale;
360 use POSIX qw(locale_h);
68021d02
KW
361 my \$in = 4.2;
362 printf("%g", \$in);
65ebb059 363EOF
385130eb
KW
364 "LANG is used if LC_ALL, LC_NUMERIC are invalid"))
365 {
366 note "To see details change this .t, do not close STDERR";
367 }
65ebb059 368 }
ff4377fe 369
385130eb
KW
370 SKIP: {
371 if ($^O eq 'MSWin32') {
372 skip("Win32 uses system default locale in preference to \"C\"",
373 1);
374 }
375 else {
376 local $ENV{LC_ALL} = "invalid";
377 local $ENV{LC_NUMERIC} = "invalid";
378 local $ENV{LANG} = "invalid";
379 local $ENV{PERL_BADLANG} = 0;
380
381 if (! fresh_perl_is(<<"EOF", 4.2, { eval $switches },
382 if (\$ENV{LC_ALL} ne "invalid") {
6ec573cf 383 no warnings "utf8";
385130eb
KW
384 print "$difference\n";
385 exit 0;
386 }
387 use locale;
388 use POSIX qw(locale_h);
389 my \$in = 4.2;
390 printf("%g", \$in);
bc8ec7cc 391EOF
385130eb
KW
392 'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid'))
393 {
394 note "To see details change this .t, do not close STDERR";
395 }
396 }
397 }
bc8ec7cc 398
385130eb
KW
399 open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
400 }
02aba72f 401
385130eb
KW
402 {
403 local $ENV{LC_NUMERIC} = $different;
404 fresh_perl_is(<<"EOF",
405 use POSIX qw(locale_h);
02aba72f 406
385130eb
KW
407 BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
408 setlocale(LC_ALL, "C");
409 use 5.008;
410 print setlocale(LC_NUMERIC);
02aba72f 411EOF
385130eb
KW
412 "C", { stderr => 'devnull' },
413 "No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix");
414 }
371d5d44 415
385130eb
KW
416 unless ($comma) {
417 skip("no locale available where LC_NUMERIC is a comma", 3);
371d5d44
KW
418 }
419 else {
385130eb 420
371d5d44 421 fresh_perl_is(<<"EOF",
385130eb
KW
422 my \$i = 1.5;
423 {
424 use locale;
425 use POSIX;
426 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
427 print \$i, "\n";
428 }
429 print \$i, "\n";
371d5d44 430EOF
385130eb 431 "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without");
02aba72f 432
385130eb
KW
433 fresh_perl_is(<<"EOF",
434 my \$i = 1.5; # Should be exactly representable as a base 2
435 # fraction, so can use 'eq' below
ee48a02a
KW
436 use locale;
437 use POSIX;
385130eb
KW
438 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
439 print \$i, "\n";
440 \$i += 1;
441 print \$i, "\n";
ee48a02a 442EOF
385130eb 443 "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800]
ee48a02a 444
c4fe5c4d 445 SKIP: {
385130eb
KW
446 unless ($have_strtod) {
447 skip("no strtod()", 1);
448 }
449 else {
450 fresh_perl_is(<<"EOF",
451 use POSIX;
452 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
453 my \$one_point_5 = POSIX::strtod("1,5");
454 \$one_point_5 =~ s/0+\$//; # Remove any trailing zeros
455 print \$one_point_5, "\n";
6e79ab66 456EOF
385130eb
KW
457 "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale");
458 }
c4fe5c4d 459 }
385130eb 460 }
6e79ab66
KW
461 }
462
8f6aacbb 463SKIP: {
8e13243a
KW
464 # Note: the setlocale Configure probe could be enhanced to give us the
465 # syntax to use, but khw doesn't think it's worth it at this time, as
466 # the current outliers seem to be skipped by the test just below
467 # anyway. If the POSIX 2008 locale functions are being used, the
468 # syntax becomes mostly irrelevant, so do the test anyway if they are.
469 # It's a lot of trouble to figure out in a perl script.
ef536431 470 if ($Config{d_setlocale_accepts_any_locale_name})
8f6aacbb 471 {
8e13243a 472 skip("Can't distinguish between valid and invalid locale names on this system", 2);
8f6aacbb
KW
473 }
474
385130eb 475 my @valid_categories = valid_locale_categories();
0945d175 476
385130eb
KW
477 my $valid_string = "";
478 my $invalid_string = "";
0945d175 479
385130eb
KW
480 # Deliberately don't include all categories, so as to test this situation
481 for my $i (0 .. @valid_categories - 2) {
482 my $category = $valid_categories[$i];
483 if ($category ne "LC_ALL") {
484 $invalid_string .= ";" if $invalid_string ne "";
485 $invalid_string .= "$category=foo_BAR";
0945d175 486
385130eb
KW
487 next unless $non_C_locale;
488 $valid_string .= ";" if $valid_string ne "";
489 $valid_string .= "$category=$non_C_locale";
490 }
0945d175 491 }
bee74f4b 492
385130eb
KW
493 fresh_perl(<<"EOF",
494 use locale;
495 use POSIX;
496 POSIX::setlocale(LC_ALL, "$invalid_string");
0945d175 497EOF
385130eb
KW
498 {});
499 is ($?, 0, "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'");
0945d175 500
385130eb
KW
501 skip("no non-C locale available", 1 ) unless $non_C_locale;
502 fresh_perl(<<"EOF",
503 use locale;
504 use POSIX;
505 POSIX::setlocale(LC_ALL, "$valid_string");
0945d175 506EOF
385130eb
KW
507 {});
508 is ($?, 0, "In setting complicated valid LC_ALL, final individ category doesn't need a \';'");
509
510 }
0945d175
KW
511
512}
513
fb072d00
TC
514SKIP:
515{
516 use locale;
517 # look for an english locale (so a < B, hopefully)
518 my ($en) = grep /^en_/, @locales;
519 POSIX::setlocale(LC_COLLATE, $en);
520 unless ("a" lt "B") {
521 skip "didn't find a suitable locale", 1;
522 }
523 fresh_perl_is(<<'EOF', "ok\n", { args => [ $en ] }, "check for failed assertion");
524use locale ':collate';
525use POSIX qw(setlocale LC_COLLATE);
526if (setlocale(LC_COLLATE, shift)) {
527 my $x = "a";
528 my $y = "B";
529 print $x lt $y ? "ok\n" : "not ok\n";
530 $x = "c"; # should empty the collxfrm magic but not remove it
531 # which the free code asserts on
532}
533else {
534 print "ok\n";
535}
536EOF
537}
538
385130eb 539done_testing();