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