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 note("locales available: @locales");
  27
  28 my $debug = 0;
  29 my $switches = "";
  30 if (defined $ARGV[0] && $ARGV[0] ne "") {
  31     if ($ARGV[0] ne 'debug') {
  32         print STDERR "Usage: $0 [ debug ]\n";
  33         exit 1
  34     }
  35     $debug = 1;
  36     $switches = "switches => [ '-DLv' ]";
  37 }
  38
  39 # reset the locale environment
  40 delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
  41
  42 # If user wants this to happen, they set the environment variable AND use
  43 # 'debug'
  44 delete local $ENV{'PERL_DEBUG_LOCALE_INIT'} unless $debug;
  45
  46 {
  47     fresh_perl_is(<<"EOF",
  48             use locale;
  49             use POSIX;
  50             POSIX::setlocale(POSIX::LC_CTYPE(),"C");
  51             print "h" =~ /[g\\w]/i || 0;
  52             print "\\n";
  53 EOF
  54         1, { stderr => 'devnull' }, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char");
  55 }
  56
  57 {
  58     fresh_perl_is(<<"EOF",
  59             use locale;
  60             use POSIX;
  61             POSIX::setlocale(POSIX::LC_CTYPE(),"C");
  62             print "0" =~ /[\\d[:punct:]]/l || 0;
  63             print "\\n";
  64 EOF
  65         1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class");
  66
  67 }
  68
  69 my $non_C_locale;
  70 foreach my $locale (@locales) {
  71     next if $locale eq "C" || $locale eq 'POSIX' || $locale eq "C.UTF-8";
  72     $non_C_locale = $locale;
  73     last;
  74 }
  75
  76 if ($non_C_locale) {
  77     note("using non-C locale '$non_C_locale'");
  78     setlocale(LC_NUMERIC, $non_C_locale);
  79     isnt(setlocale(LC_NUMERIC), "C", "retrieving current non-C LC_NUMERIC doesn't give 'C'");
  80     setlocale(LC_ALL, $non_C_locale);
  81     isnt(setlocale(LC_ALL), "C", "retrieving current non-C LC_ALL doesn't give 'C'");
  82
  83     my @test_numeric_locales = @locales;
  84
  85     # Skip this locale on these cygwin versions as the returned radix character
  86     # length is wrong
  87     if (   $^O eq 'cygwin'
  88         && version->new(($Config{'osvers'} =~ /^(\d+(?:\.\d+)+)/)[0]) le v2.4.1)
  89     {
  90         @test_numeric_locales = grep { $_ !~ m/ps_AF/i } @test_numeric_locales;
  91     }
  92
  93     # Similarly the arabic locales on solaris don't work right on the
  94     # multi-byte radix character, generating malformed UTF-8.
  95     if ($^O eq 'solaris') {
  96         @test_numeric_locales = grep { $_ !~ m/ ^ ( ar_ | pa_ ) /x }
  97                                                         @test_numeric_locales;
  98     }
  99
 100     fresh_perl_is("for (qw(@test_numeric_locales)) {\n" . <<'EOF',
 101         use POSIX qw(locale_h);
 102         use locale;
 103         setlocale(LC_NUMERIC, "$_") or next;
 104         my $s = sprintf "%g %g", 3.1, 3.1;
 105         next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
 106         no warnings "utf8";
 107         print "$_ $s\n";
 108     }
 109 EOF
 110         "", { eval $switches }, "no locales where LC_NUMERIC breaks");
 111
 112     SKIP: {
 113         skip("Windows stores locale defaults in the registry", 1 )
 114                                                                 if $^O eq 'MSWin32';
 115         fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF',
 116             use POSIX qw(locale_h);
 117             use locale;
 118             my $in = 4.2;
 119             my $s = sprintf "%g", $in; # avoid any constant folding bugs
 120             next if $s eq "4.2";
 121             no warnings "utf8";
 122             print "$_ $s\n";
 123         }
 124 EOF
 125         "", { eval $switches }, "LC_NUMERIC without environment nor setlocale() has no effect in any locale");
 126     }
 127
 128     # try to find out a locale where LC_NUMERIC makes a difference
 129     my $original_locale = setlocale(LC_NUMERIC);
 130
 131     my ($base, $different, $comma, $difference, $utf8_radix);
 132     my $radix_encoded_as_utf8;
 133     for ("C", @locales) { # prefer C for the base if available
 134         use locale;
 135         setlocale(LC_NUMERIC, $_) or next;
 136         my $in = 4.2; # avoid any constant folding bugs
 137         if ((my $s = sprintf("%g", $in)) eq "4.2")  {
 138             $base ||= $_;
 139         } else {
 140             $different ||= $_;
 141             $difference ||= $s;
 142             my $radix = localeconv()->{decimal_point};
 143
 144             # For utf8 locales with a non-ascii radix, it should be encoded as
 145             # UTF-8 with the internal flag so set.
 146             if (! defined $utf8_radix
 147                 && $radix =~ /[[:^ascii:]]/u  # /u because /l can raise warnings
 148                 && is_locale_utf8($_))
 149             {
 150                 $utf8_radix = $_;
 151                 $radix_encoded_as_utf8 = utf8::is_utf8($radix);
 152             }
 153             else {
 154                 $comma ||= $_ if $radix eq ',';
 155             }
 156         }
 157
 158         last if $base && $different && $comma && $utf8_radix;
 159     }
 160     setlocale(LC_NUMERIC, $original_locale);
 161
 162     SKIP: {
 163         skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 )
 164             unless $utf8_radix;
 165         ok($radix_encoded_as_utf8 == 1, "UTF-8 locale '$utf8_radix' with non-ASCII"
 166                                         . " radix is marked UTF-8");
 167     }
 168
 169     SKIP: {
 170         skip("no locale available where LC_NUMERIC radix isn't '.'", 30) unless $different;
 171         note("using the '$different' locale for LC_NUMERIC tests");
 172         {
 173             local $ENV{LC_NUMERIC} = $different;
 174
 175             fresh_perl_is(<<'EOF', "4.2", { eval $switches },
 176     format STDOUT =
 177 @.#
 178 4.179
 179 .
 180     write;
 181 EOF
 182                 "format() does not look at LC_NUMERIC without 'use locale'");
 183
 184     {
 185     fresh_perl_is(<<'EOF', "$difference\n", { eval $switches },
 186     use POSIX;
 187     use locale;
 188     format STDOUT =
 189 @.#
 190 4.179
 191 .
 192     write;
 193 EOF
 194                 "format() looks at LC_NUMERIC with 'use locale'");
 195             }
 196
 197             {
 198                 fresh_perl_is(<<'EOF', ",,", { eval $switches },
 199     use POSIX;
 200     no warnings "utf8";
 201     print localeconv()->{decimal_point};
 202     use locale;
 203     print localeconv()->{decimal_point};
 204 EOF
 205                 "localeconv() looks at LC_NUMERIC with and without 'use locale'");
 206             }
 207
 208             {
 209                 my $categories = ":collate :characters :collate :ctype :monetary :time";
 210                 fresh_perl_is(<<"EOF", "4.2", { eval $switches },
 211     use locale qw($categories);
 212     format STDOUT =
 213 @.#
 214 4.179
 215 .
 216     write;
 217 EOF
 218                 "format() does not look at LC_NUMERIC with 'use locale qw($categories)'");
 219             }
 220
 221             {
 222                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
 223     use locale;
 224     format STDOUT =
 225 @.#
 226 4.179
 227 .
 228     write;
 229 EOF
 230                 "format() looks at LC_NUMERIC with 'use locale'");
 231             }
 232
 233             for my $category (qw(collate characters collate ctype monetary time)) {
 234                 for my $negation ("!", "not_") {
 235                     fresh_perl_is(<<"EOF", $difference, { eval $switches },
 236     use locale ":$negation$category";
 237 format STDOUT =
 238 @.#
 239 4.179
 240 .
 241     write;
 242 EOF
 243                     "format() looks at LC_NUMERIC with 'use locale \":"
 244                     . "$negation$category\"'");
 245                 }
 246             }
 247
 248             {
 249                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
 250     use locale ":numeric";
 251 format STDOUT =
 252 @.#
 253 4.179
 254 .
 255     write;
 256 EOF
 257                 "format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
 258             }
 259
 260             {
 261                 fresh_perl_is(<<'EOF', "4.2", { eval $switches },
 262 format STDOUT =
 263 @.#
 264 4.179
 265 .
 266     { use locale; write; }
 267 EOF
 268                 "too late to look at the locale at write() time");
 269             }
 270
 271             {
 272                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
 273     use locale;
 274     format STDOUT =
 275 @.#
 276 4.179
 277 .
 278     { no locale; write; }
 279 EOF
 280                 "too late to ignore the locale at write() time");
 281             }
 282         }
 283
 284         {
 285             # do not let "use 5.000" affect the locale!
 286             # this test is to prevent regression of [rt.perl.org #105784]
 287             fresh_perl_is(<<"EOF",
 288                 use locale;
 289                 use POSIX;
 290                 my \$i = 0.123;
 291                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
 292                 \$a = sprintf("%.2f", \$i);
 293                 require version;
 294                 \$b = sprintf("%.2f", \$i);
 295                 no warnings "utf8";
 296                 print ".\$a \$b" unless \$a eq \$b
 297 EOF
 298                 "", { eval $switches }, "version does not clobber version");
 299
 300             fresh_perl_is(<<"EOF",
 301                 use locale;
 302                 use POSIX;
 303                 my \$i = 0.123;
 304                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
 305                 \$a = sprintf("%.2f", \$i);
 306                 eval "use v5.0.0";
 307                 \$b = sprintf("%.2f", \$i);
 308                 no warnings "utf8";
 309                 print "\$a \$b" unless \$a eq \$b
 310 EOF
 311                 "", { eval $switches }, "version does not clobber version (via eval)");
 312         }
 313
 314         {
 315             local $ENV{LC_NUMERIC} = $different;
 316             fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
 317                 use locale;
 318                 use POSIX qw(locale_h);
 319                 my $in = 4.2;
 320                 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
 321 EOF
 322             "sprintf() and printf() look at LC_NUMERIC regardless of constant folding");
 323         }
 324
 325         {
 326             local $ENV{LC_NUMERIC} = $different;
 327             fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
 328                 use locale;
 329                 use POSIX qw(locale_h);
 330                 my $in = 4.2;
 331                 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
 332 EOF
 333             "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC");
 334         }
 335
 336
 337         # within this block, STDERR is closed. This is because fresh_perl_is()
 338         # forks a shell, and some shells (like bash) can complain noisily when
 339         # LC_ALL or similar is set to an invalid value
 340
 341         {
 342             open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!";
 343             close STDERR;
 344
 345             {
 346                 local $ENV{LC_ALL} = "invalid";
 347                 local $ENV{LC_NUMERIC} = "invalid";
 348                 local $ENV{LANG} = $different;
 349                 local $ENV{PERL_BADLANG} = 0;
 350
 351                 if (! fresh_perl_is(<<"EOF", "$difference", { eval $switches  },
 352                     if (\$ENV{LC_ALL} ne "invalid") {
 353                         # Make the test pass if the sh didn't accept the ENV set
 354                         no warnings "utf8";
 355                         print "$difference\n";
 356                         exit 0;
 357                     }
 358                     use locale;
 359                     use POSIX qw(locale_h);
 360                     my \$in = 4.2;
 361                     printf("%g", \$in);
 362 EOF
 363                 "LANG is used if LC_ALL, LC_NUMERIC are invalid"))
 364             {
 365                 note "To see details change this .t, do not close STDERR";
 366             }
 367             }
 368
 369             SKIP: {
 370                 if ($^O eq 'MSWin32') {
 371                     skip("Win32 uses system default locale in preference to \"C\"",
 372                             1);
 373                 }
 374                 else {
 375                     local $ENV{LC_ALL} = "invalid";
 376                     local $ENV{LC_NUMERIC} = "invalid";
 377                     local $ENV{LANG} = "invalid";
 378                     local $ENV{PERL_BADLANG} = 0;
 379
 380                     if (! fresh_perl_is(<<"EOF", 4.2, { eval $switches  },
 381                         if (\$ENV{LC_ALL} ne "invalid") {
 382                             no warnings "utf8";
 383                             print "$difference\n";
 384                             exit 0;
 385                         }
 386                         use locale;
 387                         use POSIX qw(locale_h);
 388                         my \$in = 4.2;
 389                         printf("%g", \$in);
 390 EOF
 391                     'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid'))
 392                     {
 393                         note "To see details change this .t, do not close STDERR";
 394                     }
 395                 }
 396             }
 397
 398         open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
 399         }
 400
 401         {
 402             local $ENV{LC_NUMERIC} = $different;
 403             fresh_perl_is(<<"EOF",
 404                 use POSIX qw(locale_h);
 405
 406                 BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
 407                 setlocale(LC_ALL, "C");
 408                 use 5.008;
 409                 print setlocale(LC_NUMERIC);
 410 EOF
 411             "C", { stderr => 'devnull' },
 412             "No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix");
 413         }
 414
 415         unless ($comma) {
 416             skip("no locale available where LC_NUMERIC is a comma", 3);
 417         }
 418         else {
 419
 420             fresh_perl_is(<<"EOF",
 421                 my \$i = 1.5;
 422                 {
 423                     use locale;
 424                     use POSIX;
 425                     POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
 426                     print \$i, "\n";
 427                 }
 428                 print \$i, "\n";
 429 EOF
 430                 "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without");
 431
 432             fresh_perl_is(<<"EOF",
 433                 my \$i = 1.5;   # Should be exactly representable as a base 2
 434                                 # fraction, so can use 'eq' below
 435                 use locale;
 436                 use POSIX;
 437                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
 438                 print \$i, "\n";
 439                 \$i += 1;
 440                 print \$i, "\n";
 441 EOF
 442                 "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800]
 443
 444           SKIP: {
 445             unless ($have_strtod) {
 446                 skip("no strtod()", 1);
 447             }
 448             else {
 449                 fresh_perl_is(<<"EOF",
 450                     use POSIX;
 451                     POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
 452                     my \$one_point_5 = POSIX::strtod("1,5");
 453                     \$one_point_5 =~ s/0+\$//;  # Remove any trailing zeros
 454                     print \$one_point_5, "\n";
 455 EOF
 456                 "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale");
 457             }
 458           }
 459         }
 460     }
 461
 462 SKIP: {
 463         # Note: the setlocale Configure probe could be enhanced to give us the
 464         # syntax to use, but khw doesn't think it's worth it at this time, as
 465         # the current outliers seem to be skipped by the test just below
 466         # anyway.  If the POSIX 2008 locale functions are being used, the
 467         # syntax becomes mostly irrelevant, so do the test anyway if they are.
 468         # It's a lot of trouble to figure out in a perl script.
 469         if ($Config{d_setlocale_accepts_any_locale_name} eq 'true')
 470         {
 471             skip("Can't distinguish between valid and invalid locale names on this system", 2);
 472         }
 473
 474         my @valid_categories = valid_locale_categories();
 475
 476         my $valid_string = "";
 477         my $invalid_string = "";
 478
 479         # Deliberately don't include all categories, so as to test this situation
 480         for my $i (0 .. @valid_categories - 2) {
 481             my $category = $valid_categories[$i];
 482             if ($category ne "LC_ALL") {
 483                 $invalid_string .= ";" if $invalid_string ne "";
 484                 $invalid_string .= "$category=foo_BAR";
 485
 486                 next unless $non_C_locale;
 487                 $valid_string .= ";" if $valid_string ne "";
 488                 $valid_string .= "$category=$non_C_locale";
 489             }
 490         }
 491
 492         fresh_perl(<<"EOF",
 493                 use locale;
 494                 use POSIX;
 495                 POSIX::setlocale(LC_ALL, "$invalid_string");
 496 EOF
 497             {});
 498         is ($?, 0, "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'");
 499
 500         skip("no non-C locale available", 1 ) unless $non_C_locale;
 501         fresh_perl(<<"EOF",
 502                 use locale;
 503                 use POSIX;
 504                 POSIX::setlocale(LC_ALL, "$valid_string");
 505 EOF
 506             {});
 507         is ($?, 0, "In setting complicated valid LC_ALL, final individ category doesn't need a \';'");
 508
 509     }
 510
 511 }
 512
 513 done_testing();