This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
db75b444cea9c150dd9d02d52f446ace54d35f62
[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
27 # reset the locale environment
28 delete local @ENV{'LANG', (grep /^LC_/, keys %ENV)};
29
30 plan tests => &last;
31
32 my $non_C_locale;
33 foreach my $locale (@locales) {
34     next if $locale eq "C" || $locale eq 'POSIX';
35     $non_C_locale = $locale;
36     last;
37 }
38
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
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',
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
64 SKIP: {
65     skip("Windows stores locale defaults in the registry", 1 )
66                                                             if $^O eq 'MSWin32';
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     }
75 EOF
76     "", {}, "LC_NUMERIC without environment nor setlocale() has no effect in any locale");
77 }
78
79 # try to find out a locale where LC_NUMERIC makes a difference
80 my $original_locale = setlocale(LC_NUMERIC);
81
82 my ($base, $different, $comma, $difference, $utf8_radix);
83 my $radix_encoded_as_utf8;
84 for ("C", @locales) { # prefer C for the base if available
85     use locale;
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;
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         }
107     }
108
109     last if $base && $different && $comma && $utf8_radix;
110 }
111 setlocale(LC_NUMERIC, $original_locale);
112
113 SKIP: {
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: {
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
123     note("using the '$different' locale for LC_NUMERIC tests");
124     {
125         local $ENV{LC_NUMERIC} = $different;
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         {
137             fresh_perl_is(<<'EOF', "$difference\n", {},
138 use POSIX;
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         {
150             fresh_perl_is(<<'EOF', ",,", {},
151 use POSIX;
152 print localeconv()->{decimal_point};
153 use locale;
154 print localeconv()->{decimal_point};
155 EOF
156             "localeconv() looks at LC_NUMERIC with and without 'use locale'");
157         }
158
159         {
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         {
200             fresh_perl_is(<<'EOF', $difference, {},
201 use locale ":numeric";
202 format STDOUT =
203 @.#
204 4.179
205 .
206 write;
207 EOF
208             "format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
209         }
210
211         {
212             fresh_perl_is(<<'EOF', "4.2", {},
213 format STDOUT =
214 @.#
215 4.179
216 .
217 { use locale; write; }
218 EOF
219             "too late to look at the locale at write() time");
220         }
221
222         {
223             fresh_perl_is(<<'EOF', $difference, {},
224 use locale;
225 format STDOUT =
226 @.#
227 4.179
228 .
229 { no locale; write; }
230 EOF
231             "too late to ignore the locale at write() time");
232         }
233     }
234
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",
239             use locale;
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
263     {
264         local $ENV{LC_NUMERIC} = $different;
265         fresh_perl_is(<<'EOF', "$difference "x4, {},
266             use locale;
267             use POSIX qw(locale_h);
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     }
273
274     {
275         local $ENV{LC_NUMERIC} = $different;
276         fresh_perl_is(<<'EOF', "$difference "x4, {},
277             use locale;
278             use POSIX qw(locale_h);
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
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
288     # LC_ALL or similar is set to an invalid value
289
290     {
291         open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!";
292         close STDERR;
293
294         {
295             local $ENV{LC_ALL} = "invalid";
296             local $ENV{LC_NUMERIC} = "invalid";
297             local $ENV{LANG} = $different;
298             local $ENV{PERL_BADLANG} = 0;
299
300             if (! fresh_perl_is(<<"EOF", "$difference", { },
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                 }
306                 use locale;
307                 use POSIX qw(locale_h);
308                 my \$in = 4.2;
309                 printf("%g", \$in);
310 EOF
311             "LANG is used if LC_ALL, LC_NUMERIC are invalid"))
312            {
313               note "To see details change this .t, do not close STDERR";
314            }
315         }
316
317         SKIP: {
318             if ($^O eq 'MSWin32') {
319                 skip("Win32 uses system default locale in preference to \"C\"",
320                         1);
321             }
322             else {
323                 local $ENV{LC_ALL} = "invalid";
324                 local $ENV{LC_NUMERIC} = "invalid";
325                 local $ENV{LANG} = "invalid";
326                 local $ENV{PERL_BADLANG} = 0;
327
328                 if (! fresh_perl_is(<<"EOF", 4.2, { },
329                     if (\$ENV{LC_ALL} ne "invalid") {
330                         print "$difference\n";
331                         exit 0;
332                     }
333                     use locale;
334                     use POSIX qw(locale_h);
335                     my \$in = 4.2;
336                     printf("%g", \$in);
337 EOF
338                 'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid'))
339                 {
340                     note "To see details change this .t, do not close STDERR";
341                 }
342             }
343         }
344
345     open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
346     }
347
348     {
349         local $ENV{LC_NUMERIC} = $different;
350         fresh_perl_is(<<"EOF",
351             use POSIX qw(locale_h);
352
353             BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
354             setlocale(LC_ALL, "C");
355             use 5.008;
356             print setlocale(LC_NUMERIC);
357 EOF
358          "C", { stderr => 'devnull' },
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
362     unless ($comma) {
363         skip("no locale available where LC_NUMERIC is a comma", 3);
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
377             "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without");
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
389             "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800]
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
402             "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale");
403         }
404     }
405 } # SKIP
406
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
415             1, { stderr => 'devnull' }, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char");
416     }
417
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
426             1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class");
427
428     }
429
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", ...)
433 sub last { 37 }