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';
  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     if ($different) {
 170         note("using the '$different' locale for LC_NUMERIC tests");
 171         {
 172             local $ENV{LC_NUMERIC} = $different;
 173
 174             fresh_perl_is(<<'EOF', "4.2", { eval $switches },
 175     format STDOUT =
 176 @.#
 177 4.179
 178 .
 179     write;
 180 EOF
 181                 "format() does not look at LC_NUMERIC without 'use locale'");
 182
 183     {
 184     fresh_perl_is(<<'EOF', "$difference\n", { eval $switches },
 185     use POSIX;
 186     use locale;
 187     format STDOUT =
 188 @.#
 189 4.179
 190 .
 191     write;
 192 EOF
 193                 "format() looks at LC_NUMERIC with 'use locale'");
 194             }
 195
 196             {
 197                 fresh_perl_is(<<'EOF', ",,", { eval $switches },
 198     use POSIX;
 199     no warnings "utf8";
 200     print localeconv()->{decimal_point};
 201     use locale;
 202     print localeconv()->{decimal_point};
 203 EOF
 204                 "localeconv() looks at LC_NUMERIC with and without 'use locale'");
 205             }
 206
 207             {
 208                 my $categories = ":collate :characters :collate :ctype :monetary :time";
 209                 fresh_perl_is(<<"EOF", "4.2", { eval $switches },
 210     use locale qw($categories);
 211     format STDOUT =
 212 @.#
 213 4.179
 214 .
 215     write;
 216 EOF
 217                 "format() does not look at LC_NUMERIC with 'use locale qw($categories)'");
 218             }
 219
 220             {
 221                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
 222     use locale;
 223     format STDOUT =
 224 @.#
 225 4.179
 226 .
 227     write;
 228 EOF
 229                 "format() looks at LC_NUMERIC with 'use locale'");
 230             }
 231
 232             for my $category (qw(collate characters collate ctype monetary time)) {
 233                 for my $negation ("!", "not_") {
 234                     fresh_perl_is(<<"EOF", $difference, { eval $switches },
 235     use locale ":$negation$category";
 236 format STDOUT =
 237 @.#
 238 4.179
 239 .
 240     write;
 241 EOF
 242                     "format() looks at LC_NUMERIC with 'use locale \":"
 243                     . "$negation$category\"'");
 244                 }
 245             }
 246
 247             {
 248                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
 249     use locale ":numeric";
 250 format STDOUT =
 251 @.#
 252 4.179
 253 .
 254     write;
 255 EOF
 256                 "format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
 257             }
 258
 259             {
 260                 fresh_perl_is(<<'EOF', "4.2", { eval $switches },
 261 format STDOUT =
 262 @.#
 263 4.179
 264 .
 265     { use locale; write; }
 266 EOF
 267                 "too late to look at the locale at write() time");
 268             }
 269
 270             {
 271                 fresh_perl_is(<<'EOF', $difference, { eval $switches },
 272     use locale;
 273     format STDOUT =
 274 @.#
 275 4.179
 276 .
 277     { no locale; write; }
 278 EOF
 279                 "too late to ignore the locale at write() time");
 280             }
 281         }
 282
 283         {
 284             # do not let "use 5.000" affect the locale!
 285             # this test is to prevent regression of [rt.perl.org #105784]
 286             fresh_perl_is(<<"EOF",
 287                 use locale;
 288                 use POSIX;
 289                 my \$i = 0.123;
 290                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
 291                 \$a = sprintf("%.2f", \$i);
 292                 require version;
 293                 \$b = sprintf("%.2f", \$i);
 294                 no warnings "utf8";
 295                 print ".\$a \$b" unless \$a eq \$b
 296 EOF
 297                 "", { eval $switches }, "version does not clobber version");
 298
 299             fresh_perl_is(<<"EOF",
 300                 use locale;
 301                 use POSIX;
 302                 my \$i = 0.123;
 303                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
 304                 \$a = sprintf("%.2f", \$i);
 305                 eval "use v5.0.0";
 306                 \$b = sprintf("%.2f", \$i);
 307                 no warnings "utf8";
 308                 print "\$a \$b" unless \$a eq \$b
 309 EOF
 310                 "", { eval $switches }, "version does not clobber version (via eval)");
 311         }
 312
 313         {
 314             local $ENV{LC_NUMERIC} = $different;
 315             fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
 316                 use locale;
 317                 use POSIX qw(locale_h);
 318                 my $in = 4.2;
 319                 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
 320 EOF
 321             "sprintf() and printf() look at LC_NUMERIC regardless of constant folding");
 322         }
 323
 324         {
 325             local $ENV{LC_NUMERIC} = $different;
 326             fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
 327                 use locale;
 328                 use POSIX qw(locale_h);
 329                 my $in = 4.2;
 330                 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
 331 EOF
 332             "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC");
 333         }
 334
 335
 336         # within this block, STDERR is closed. This is because fresh_perl_is()
 337         # forks a shell, and some shells (like bash) can complain noisily when
 338         # LC_ALL or similar is set to an invalid value
 339
 340         {
 341             open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!";
 342             close STDERR;
 343
 344             {
 345                 local $ENV{LC_ALL} = "invalid";
 346                 local $ENV{LC_NUMERIC} = "invalid";
 347                 local $ENV{LANG} = $different;
 348                 local $ENV{PERL_BADLANG} = 0;
 349
 350                 if (! fresh_perl_is(<<"EOF", "$difference", { eval $switches  },
 351                     if (\$ENV{LC_ALL} ne "invalid") {
 352                         # Make the test pass if the sh didn't accept the ENV set
 353                         no warnings "utf8";
 354                         print "$difference\n";
 355                         exit 0;
 356                     }
 357                     use locale;
 358                     use POSIX qw(locale_h);
 359                     my \$in = 4.2;
 360                     printf("%g", \$in);
 361 EOF
 362                 "LANG is used if LC_ALL, LC_NUMERIC are invalid"))
 363             {
 364                 note "To see details change this .t, do not close STDERR";
 365             }
 366             }
 367
 368             SKIP: {
 369                 if ($^O eq 'MSWin32') {
 370                     skip("Win32 uses system default locale in preference to \"C\"",
 371                             1);
 372                 }
 373                 else {
 374                     local $ENV{LC_ALL} = "invalid";
 375                     local $ENV{LC_NUMERIC} = "invalid";
 376                     local $ENV{LANG} = "invalid";
 377                     local $ENV{PERL_BADLANG} = 0;
 378
 379                     if (! fresh_perl_is(<<"EOF", 4.2, { eval $switches  },
 380                         if (\$ENV{LC_ALL} ne "invalid") {
 381                             no warnings "utf8";
 382                             print "$difference\n";
 383                             exit 0;
 384                         }
 385                         use locale;
 386                         use POSIX qw(locale_h);
 387                         my \$in = 4.2;
 388                         printf("%g", \$in);
 389 EOF
 390                     'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid'))
 391                     {
 392                         note "To see details change this .t, do not close STDERR";
 393                     }
 394                 }
 395             }
 396
 397         open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
 398         }
 399
 400         {
 401             local $ENV{LC_NUMERIC} = $different;
 402             fresh_perl_is(<<"EOF",
 403                 use POSIX qw(locale_h);
 404
 405                 BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
 406                 setlocale(LC_ALL, "C");
 407                 use 5.008;
 408                 print setlocale(LC_NUMERIC);
 409 EOF
 410             "C", { stderr => 'devnull' },
 411             "No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix");
 412         }
 413
 414         unless ($comma) {
 415             skip("no locale available where LC_NUMERIC is a comma", 3);
 416         }
 417         else {
 418
 419             fresh_perl_is(<<"EOF",
 420                 my \$i = 1.5;
 421                 {
 422                     use locale;
 423                     use POSIX;
 424                     POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
 425                     print \$i, "\n";
 426                 }
 427                 print \$i, "\n";
 428 EOF
 429                 "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without");
 430
 431             fresh_perl_is(<<"EOF",
 432                 my \$i = 1.5;   # Should be exactly representable as a base 2
 433                                 # fraction, so can use 'eq' below
 434                 use locale;
 435                 use POSIX;
 436                 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
 437                 print \$i, "\n";
 438                 \$i += 1;
 439                 print \$i, "\n";
 440 EOF
 441                 "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800]
 442
 443           SKIP: {
 444             unless ($have_strtod) {
 445                 skip("no strtod()", 1);
 446             }
 447             else {
 448                 fresh_perl_is(<<"EOF",
 449                     use POSIX;
 450                     POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
 451                     my \$one_point_5 = POSIX::strtod("1,5");
 452                     \$one_point_5 =~ s/0+\$//;  # Remove any trailing zeros
 453                     print \$one_point_5, "\n";
 454 EOF
 455                 "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale");
 456             }
 457           }
 458         }
 459     }
 460
 461     {
 462         my @valid_categories = valid_locale_categories();
 463
 464         my $valid_string = "";
 465         my $invalid_string = "";
 466
 467         # Deliberately don't include all categories, so as to test this situation
 468         for my $i (0 .. @valid_categories - 2) {
 469             my $category = $valid_categories[$i];
 470             if ($category ne "LC_ALL") {
 471                 $invalid_string .= ";" if $invalid_string ne "";
 472                 $invalid_string .= "$category=foo_BAR";
 473
 474                 next unless $non_C_locale;
 475                 $valid_string .= ";" if $valid_string ne "";
 476                 $valid_string .= "$category=$non_C_locale";
 477             }
 478         }
 479
 480         fresh_perl(<<"EOF",
 481                 use locale;
 482                 use POSIX;
 483                 POSIX::setlocale(LC_ALL, "$invalid_string");
 484 EOF
 485             {});
 486         is ($?, 0, "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'");
 487
 488         skip("no non-C locale available", 1 ) unless $non_C_locale;
 489         fresh_perl(<<"EOF",
 490                 use locale;
 491                 use POSIX;
 492                 POSIX::setlocale(LC_ALL, "$valid_string");
 493 EOF
 494             {});
 495         is ($?, 0, "In setting complicated valid LC_ALL, final individ category doesn't need a \';'");
 496
 497     }
 498
 499 }
 500
 501 done_testing();