This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/run/locale.t: Remove unnecessary setlocales()
[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 in 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 = eval { find_locales( [ &LC_ALL, &LC_CTYPE, &LC_NUMERIC ] ) };
25 skip_all("no locales available") unless @locales;
26
27 plan tests => &last;
28 fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF',
29     use POSIX qw(locale_h);
30     use locale;
31     setlocale(LC_NUMERIC, "$_") or next;
32     my $s = sprintf "%g %g", 3.1, 3.1;
33     next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
34     print "$_ $s\n";
35 }
36 EOF
37     "", {}, "no locales where LC_NUMERIC breaks");
38
39 {
40     local $ENV{LC_NUMERIC}; # So not taken as a default
41     local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC
42     local $ENV{LANG};   # So not taken as a default
43     fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF',
44         use POSIX qw(locale_h);
45         use locale;
46         my $in = 4.2;
47         my $s = sprintf "%g", $in; # avoid any constant folding bugs
48         next if $s eq "4.2";
49         print "$_ $s\n";
50     }
51 EOF
52     "", {}, "LC_NUMERIC without environment nor setlocale() has no effect in any locale");
53 }
54
55 # try to find out a locale where LC_NUMERIC makes a difference
56 my $original_locale = setlocale(LC_NUMERIC);
57
58 my ($base, $different, $comma, $difference, $utf8_radix);
59 my $radix_encoded_as_utf8;
60 for ("C", @locales) { # prefer C for the base if available
61     use locale;
62     setlocale(LC_NUMERIC, $_) or next;
63     my $in = 4.2; # avoid any constant folding bugs
64     if ((my $s = sprintf("%g", $in)) eq "4.2")  {
65         $base ||= $_;
66     } else {
67         $different ||= $_;
68         $difference ||= $s;
69         my $radix = localeconv()->{decimal_point};
70
71         # For utf8 locales with a non-ascii radix, it should be encoded as
72         # UTF-8 with the internal flag so set.
73         if (! defined $utf8_radix
74             && $radix =~ /[[:^ascii:]]/
75             && is_locale_utf8($_))
76         {
77             $utf8_radix = $_;
78             $radix_encoded_as_utf8 = utf8::is_utf8($radix);
79         }
80         else {
81             $comma ||= $_ if $radix eq ',';
82         }
83     }
84
85     last if $base && $different && $comma && $utf8_radix;
86 }
87 setlocale(LC_NUMERIC, $original_locale);
88
89 SKIP: {
90     skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 )
91         unless $utf8_radix;
92     ok($radix_encoded_as_utf8 == 1, "UTF-8 locale '$utf8_radix' with non-ASCII"
93                                     . " radix is marked UTF-8");
94 }
95
96 SKIP: {
97     skip("no locale available where LC_NUMERIC makes a difference", &last - 5 )
98         if !$different;     # -5 is 3 tests before this block; 2 after
99     note("using the '$different' locale for LC_NUMERIC tests");
100     {
101         local $ENV{LC_NUMERIC} = $different;
102         local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC
103
104         fresh_perl_is(<<'EOF', "4.2", {},
105 format STDOUT =
106 @.#
107 4.179
108 .
109 write;
110 EOF
111             "format() does not look at LC_NUMERIC without 'use locale'");
112
113         {
114             fresh_perl_is(<<'EOF', "$difference\n", {},
115 use POSIX;
116 use locale;
117 format STDOUT =
118 @.#
119 4.179
120 .
121 write;
122 EOF
123             "format() looks at LC_NUMERIC with 'use locale'");
124         }
125
126         {
127             fresh_perl_is(<<'EOF', ",,", {},
128 print localeconv()->{decimal_point};
129 use POSIX;
130 use locale;
131 print localeconv()->{decimal_point};
132 EOF
133             "localeconv() looks at LC_NUMERIC with and without 'use locale'");
134         }
135
136         {
137             my $categories = ":collate :characters :collate :ctype :monetary :time";
138             fresh_perl_is(<<"EOF", "4.2", {},
139 use locale qw($categories);
140 format STDOUT =
141 @.#
142 4.179
143 .
144 write;
145 EOF
146             "format() does not look at LC_NUMERIC with 'use locale qw($categories)'");
147         }
148
149         {
150             fresh_perl_is(<<'EOF', $difference, {},
151 use locale;
152 format STDOUT =
153 @.#
154 4.179
155 .
156 write;
157 EOF
158             "format() looks at LC_NUMERIC with 'use locale'");
159         }
160
161         for my $category (qw(collate characters collate ctype monetary time)) {
162             for my $negation ("!", "not_") {
163                 fresh_perl_is(<<"EOF", $difference, {},
164 use locale ":$negation$category";
165 format STDOUT =
166 @.#
167 4.179
168 .
169 write;
170 EOF
171                 "format() looks at LC_NUMERIC with 'use locale \":"
172                 . "$negation$category\"'");
173             }
174         }
175
176         {
177             fresh_perl_is(<<'EOF', $difference, {},
178 use locale ":numeric";
179 format STDOUT =
180 @.#
181 4.179
182 .
183 write;
184 EOF
185             "format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
186         }
187
188         {
189             fresh_perl_is(<<'EOF', "4.2", {},
190 format STDOUT =
191 @.#
192 4.179
193 .
194 { use locale; write; }
195 EOF
196             "too late to look at the locale at write() time");
197         }
198
199         {
200             fresh_perl_is(<<'EOF', $difference, {},
201 use locale;
202 format STDOUT =
203 @.#
204 4.179
205 .
206 { no locale; write; }
207 EOF
208             "too late to ignore the locale at write() time");
209         }
210     }
211
212     {
213         # do not let "use 5.000" affect the locale!
214         # this test is to prevent regression of [rt.perl.org #105784]
215         fresh_perl_is(<<"EOF",
216             use locale;
217             use POSIX;
218             my \$i = 0.123;
219             POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
220             \$a = sprintf("%.2f", \$i);
221             require version;
222             \$b = sprintf("%.2f", \$i);
223             print ".\$a \$b" unless \$a eq \$b
224 EOF
225             "", {}, "version does not clobber version");
226
227         fresh_perl_is(<<"EOF",
228             use locale;
229             use POSIX;
230             my \$i = 0.123;
231             POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
232             \$a = sprintf("%.2f", \$i);
233             eval "use v5.0.0";
234             \$b = sprintf("%.2f", \$i);
235             print "\$a \$b" unless \$a eq \$b
236 EOF
237             "", {}, "version does not clobber version (via eval)");
238     }
239
240     {
241         local $ENV{LC_NUMERIC} = $different;
242         local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC
243         fresh_perl_is(<<'EOF', "$difference "x4, {},
244             use locale;
245             use POSIX qw(locale_h);
246             my $in = 4.2;
247             printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
248 EOF
249         "sprintf() and printf() look at LC_NUMERIC regardless of constant folding");
250     }
251
252     {
253         local $ENV{LC_NUMERIC} = $different;
254         local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC
255         local $ENV{LANG};   # so on Windows gets sys default locale
256         fresh_perl_is(<<'EOF', "$difference "x4, {},
257             use locale;
258             use POSIX qw(locale_h);
259             my $in = 4.2;
260             printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
261 EOF
262         "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC");
263     }
264
265
266     # within this block, STDERR is closed. This is because fresh_perl_is()
267     # forks a shell, and some shells (like bash) can complain noisily when
268     #LC_ALL or similar is set to an invalid value
269
270     {
271         open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!";
272         close STDERR;
273
274         {
275             local $ENV{LC_ALL} = "invalid";
276             local $ENV{LC_NUMERIC} = "invalid";
277             local $ENV{LANG} = $different;
278
279             # Can't turn off the warnings, so send them to /dev/null
280             if (! fresh_perl_is(<<"EOF", "$difference", { stderr => "devnull" },
281                 if (\$ENV{LC_ALL} ne "invalid") {
282                     # Make the test pass if the sh didn't accept the ENV set
283                     print "$difference\n";
284                     exit 0;
285                 }
286                 use locale;
287                 use POSIX qw(locale_h);
288                 my \$in = 4.2;
289                 printf("%g", \$in);
290 EOF
291             "LANG is used if LC_ALL, LC_NUMERIC are invalid"))
292            {
293               note "To see details change this .t to not close STDERR";
294            }
295         }
296
297         SKIP: {
298             if ($^O eq 'MSWin32') {
299                 skip("Win32 uses system default locale in preference to \"C\"",
300                         1);
301             }
302             else {
303                 local $ENV{LC_ALL} = "invalid";
304                 local $ENV{LC_NUMERIC} = "invalid";
305                 local $ENV{LANG} = "invalid";
306
307                 # Can't turn off the warnings, so send them to /dev/null
308                 if (! fresh_perl_is(<<"EOF", 4.2, { stderr => "devnull" },
309                     if (\$ENV{LC_ALL} ne "invalid") {
310                         print "$difference\n";
311                         exit 0;
312                     }
313                     use locale;
314                     use POSIX qw(locale_h);
315                     my \$in = 4.2;
316                     printf("%g", \$in);
317 EOF
318                 'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid'))
319                 {
320                     note "To see details change this .t to not close STDERR";
321                 }
322             }
323         }
324
325     open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
326     }
327
328     {
329         local $ENV{LC_NUMERIC} = $different;
330         local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC
331         fresh_perl_is(<<"EOF",
332             use POSIX qw(locale_h);
333
334             BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
335             setlocale(LC_ALL, "C");
336             use 5.008;
337             print setlocale(LC_NUMERIC);
338 EOF
339          "C", { },
340          "No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix");
341     }
342
343     unless ($comma) {
344         skip("no locale available where LC_NUMERIC is a comma", 3);
345     }
346     else {
347
348         fresh_perl_is(<<"EOF",
349             my \$i = 1.5;
350             {
351                 use locale;
352                 use POSIX;
353                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
354                 print \$i, "\n";
355             }
356             print \$i, "\n";
357 EOF
358             "1,5\n1.5", {}, "Radix print properly in locale scope, and without");
359
360         fresh_perl_is(<<"EOF",
361             my \$i = 1.5;   # Should be exactly representable as a base 2
362                             # fraction, so can use 'eq' below
363             use locale;
364             use POSIX;
365             POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
366             print \$i, "\n";
367             \$i += 1;
368             print \$i, "\n";
369 EOF
370             "1,5\n2,5", {}, "Can do math when radix is a comma"); # [perl 115800]
371
372         unless ($have_strtod) {
373             skip("no strtod()", 1);
374         }
375         else {
376             fresh_perl_is(<<"EOF",
377                 use POSIX;
378                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
379                 my \$one_point_5 = POSIX::strtod("1,5");
380                 \$one_point_5 =~ s/0+\$//;  # Remove any trailing zeros
381                 print \$one_point_5, "\n";
382 EOF
383             "1.5", {}, "POSIX::strtod() uses underlying locale");
384         }
385     }
386 } # SKIP
387
388     {
389         fresh_perl_is(<<"EOF",
390                 use locale;
391                 use POSIX;
392                 POSIX::setlocale(POSIX::LC_CTYPE(),"C");
393                 print "h" =~ /[g\\w]/i || 0;
394                 print "\\n";
395 EOF
396             1, {}, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char");
397     }
398
399     {
400         fresh_perl_is(<<"EOF",
401                 use locale;
402                 use POSIX;
403                 POSIX::setlocale(POSIX::LC_CTYPE(),"C");
404                 print "0" =~ /[\\d[:punct:]]/l || 0;
405                 print "\\n";
406 EOF
407             1, {}, "/l matching of [bracketed] doesn't skip non-first POSIX class");
408
409     }
410
411 sub last { 35 }