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