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