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