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