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
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 use warnings;
11
12 ########
13 # These tests are here instead of lib/locale.t because
14 # some bugs depend on the internal state of the locale
15 # settings and pragma/locale messes up that state pretty badly.
16 # We need "fresh runs".
17 BEGIN {
18     eval { require POSIX; POSIX->import("locale_h") };
19     if ($@) {
20         skip_all("could not load the POSIX module"); # running minitest?
21     }
22 }
23 use Config;
24 my $have_strtod = $Config{d_strtod} eq 'define';
25 my @locales = find_locales( [ 'LC_ALL', 'LC_CTYPE', 'LC_NUMERIC' ]);
26 skip_all("no locales available") unless @locales;
27 note("locales available: @locales");
28
29 my $debug = 0;
30 my $switches = "";
31 if (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
40 # reset the locale environment
41 delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
42
43 # If user wants this to happen, they set the environment variable AND use
44 # 'debug'
45 delete local $ENV{'PERL_DEBUG_LOCALE_INIT'} unless $debug;
46
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";
54 EOF
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";
65 EOF
66         1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class");
67
68 }
69
70 my $non_C_locale;
71 foreach my $locale (@locales) {
72     next if $locale eq "C" || $locale eq 'POSIX' || $locale eq "C.UTF-8";
73     $non_C_locale = $locale;
74     last;
75 }
76
77 if ($non_C_locale) {
78     note("using non-C locale '$non_C_locale'");
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'");
83
84     my @test_numeric_locales = @locales;
85
86     # Skip this locale on these cygwin versions as the returned radix character
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     }
93
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
101     fresh_perl_is("for (qw(@test_numeric_locales)) {\n" . <<'EOF',
102         use POSIX qw(locale_h);
103         use locale;
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$/;
107         no warnings "utf8";
108         print "$_ $s\n";
109     }
110 EOF
111         "", { eval $switches }, "no locales where LC_NUMERIC breaks");
112
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";
122             no warnings "utf8";
123             print "$_ $s\n";
124         }
125 EOF
126         "", { eval $switches }, "LC_NUMERIC without environment nor setlocale() has no effect in any locale");
127     }
128
129     # try to find out a locale where LC_NUMERIC makes a difference
130     my $original_locale = setlocale(LC_NUMERIC);
131
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
148                 && $radix =~ /[[:^ascii:]]/u  # /u because /l can raise warnings
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         }
158
159         last if $base && $different && $comma && $utf8_radix;
160     }
161     setlocale(LC_NUMERIC, $original_locale);
162
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
170     SKIP: {
171         skip("no locale available where LC_NUMERIC radix isn't '.'", 30) unless $different;
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 =
178 @.#
179 4.179
180 .
181     write;
182 EOF
183                 "format() does not look at LC_NUMERIC without 'use locale'");
184
185     {
186     fresh_perl_is(<<'EOF', "$difference\n", { eval $switches },
187     use POSIX;
188     use locale;
189     format STDOUT =
190 @.#
191 4.179
192 .
193     write;
194 EOF
195                 "format() looks at LC_NUMERIC with 'use locale'");
196             }
197
198             {
199                 fresh_perl_is(<<'EOF', ",,", { eval $switches },
200     use POSIX;
201     no warnings "utf8";
202     print localeconv()->{decimal_point};
203     use locale;
204     print localeconv()->{decimal_point};
205 EOF
206                 "localeconv() looks at LC_NUMERIC with and without 'use locale'");
207             }
208
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 =
214 @.#
215 4.179
216 .
217     write;
218 EOF
219                 "format() does not look at LC_NUMERIC with 'use locale qw($categories)'");
220             }
221
222             {
223                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
224     use locale;
225     format STDOUT =
226 @.#
227 4.179
228 .
229     write;
230 EOF
231                 "format() looks at LC_NUMERIC with 'use locale'");
232             }
233
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";
238 format STDOUT =
239 @.#
240 4.179
241 .
242     write;
243 EOF
244                     "format() looks at LC_NUMERIC with 'use locale \":"
245                     . "$negation$category\"'");
246                 }
247             }
248
249             {
250                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
251     use locale ":numeric";
252 format STDOUT =
253 @.#
254 4.179
255 .
256     write;
257 EOF
258                 "format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
259             }
260
261             {
262                 fresh_perl_is(<<'EOF', "4.2", { eval $switches },
263 format STDOUT =
264 @.#
265 4.179
266 .
267     { use locale; write; }
268 EOF
269                 "too late to look at the locale at write() time");
270             }
271
272             {
273                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
274     use locale;
275     format STDOUT =
276 @.#
277 4.179
278 .
279     { no locale; write; }
280 EOF
281                 "too late to ignore the locale at write() time");
282             }
283         }
284
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);
296                 no warnings "utf8";
297                 print ".\$a \$b" unless \$a eq \$b
298 EOF
299                 "", { eval $switches }, "version does not clobber version");
300
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);
309                 no warnings "utf8";
310                 print "\$a \$b" unless \$a eq \$b
311 EOF
312                 "", { eval $switches }, "version does not clobber version (via eval)");
313         }
314
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));
322 EOF
323             "sprintf() and printf() look at LC_NUMERIC regardless of constant folding");
324         }
325
326         {
327             local $ENV{LC_NUMERIC} = $different;
328             fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
329                 use locale;
330                 use POSIX qw(locale_h);
331                 my $in = 4.2;
332                 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
333 EOF
334             "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC");
335         }
336
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             {
347                 local $ENV{LC_ALL} = "invalid";
348                 local $ENV{LC_NUMERIC} = "invalid";
349                 local $ENV{LANG} = $different;
350                 local $ENV{PERL_BADLANG} = 0;
351
352                 if (! fresh_perl_is(<<"EOF", "$difference", { eval $switches  },
353                     if (\$ENV{LC_ALL} ne "invalid") {
354                         # Make the test pass if the sh didn't accept the ENV set
355                         no warnings "utf8";
356                         print "$difference\n";
357                         exit 0;
358                     }
359                     use locale;
360                     use POSIX qw(locale_h);
361                     my \$in = 4.2;
362                     printf("%g", \$in);
363 EOF
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             }
368             }
369
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") {
383                             no warnings "utf8";
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);
391 EOF
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             }
398
399         open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
400         }
401
402         {
403             local $ENV{LC_NUMERIC} = $different;
404             fresh_perl_is(<<"EOF",
405                 use POSIX qw(locale_h);
406
407                 BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
408                 setlocale(LC_ALL, "C");
409                 use 5.008;
410                 print setlocale(LC_NUMERIC);
411 EOF
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         }
415
416         unless ($comma) {
417             skip("no locale available where LC_NUMERIC is a comma", 3);
418         }
419         else {
420
421             fresh_perl_is(<<"EOF",
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";
430 EOF
431                 "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without");
432
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
436                 use locale;
437                 use POSIX;
438                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
439                 print \$i, "\n";
440                 \$i += 1;
441                 print \$i, "\n";
442 EOF
443                 "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800]
444
445           SKIP: {
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";
456 EOF
457                 "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale");
458             }
459           }
460         }
461     }
462
463 SKIP: {
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.
470         if ($Config{d_setlocale_accepts_any_locale_name})
471         {
472             skip("Can't distinguish between valid and invalid locale names on this system", 2);
473         }
474
475         my @valid_categories = valid_locale_categories();
476
477         my $valid_string = "";
478         my $invalid_string = "";
479
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";
486
487                 next unless $non_C_locale;
488                 $valid_string .= ";" if $valid_string ne "";
489                 $valid_string .= "$category=$non_C_locale";
490             }
491         }
492
493         fresh_perl(<<"EOF",
494                 use locale;
495                 use POSIX;
496                 POSIX::setlocale(LC_ALL, "$invalid_string");
497 EOF
498             {});
499         is ($?, 0, "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'");
500
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");
506 EOF
507             {});
508         is ($?, 0, "In setting complicated valid LC_ALL, final individ category doesn't need a \';'");
509
510     }
511
512 }
513
514 SKIP:
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");
524 use locale ':collate';
525 use POSIX qw(setlocale LC_COLLATE);
526 if (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 }
533 else {
534      print "ok\n";
535 }
536 EOF
537 }
538
539 done_testing();