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 print localeconv()->{decimal_point};
 152 use POSIX;
 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 }