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