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