1#!./perl 2BEGIN { 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 9use 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". 16BEGIN { 17 eval { require POSIX; POSIX->import("locale_h") }; 18 if ($@) { 19 skip_all("could not load the POSIX module"); # running minitest? 20 } 21} 22use Config; 23my $have_strtod = $Config{d_strtod} eq 'define'; 24my @locales = find_locales( [ 'LC_ALL', 'LC_CTYPE', 'LC_NUMERIC' ]); 25skip_all("no locales available") unless @locales; 26 27my $debug = 0; 28my $switches = ""; 29if (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 39delete 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' 43delete 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"; 52EOF 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"; 63EOF 64 1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class"); 65 66} 67 68my $non_C_locale; 69foreach my $locale (@locales) { 70 next if $locale eq "C" || $locale eq 'POSIX'; 71 $non_C_locale = $locale; 72 last; 73} 74 75if ($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 } 107EOF 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 } 122EOF 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@.# 1754.179 176. 177 write; 178EOF 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@.# 1874.179 188. 189 write; 190EOF 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}; 201EOF 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@.# 2114.179 212. 213 write; 214EOF 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@.# 2234.179 224. 225 write; 226EOF 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"; 234format STDOUT = 235@.# 2364.179 237. 238 write; 239EOF 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"; 248format STDOUT = 249@.# 2504.179 251. 252 write; 253EOF 254 "format() looks at LC_NUMERIC with 'use locale \":numeric\"'"); 255 } 256 257 { 258 fresh_perl_is(<<'EOF', "4.2", { eval $switches }, 259format STDOUT = 260@.# 2614.179 262. 263 { use locale; write; } 264EOF 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@.# 2734.179 274. 275 { no locale; write; } 276EOF 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 294EOF 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 307EOF 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)); 318EOF 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)); 329EOF 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); 359EOF 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); 387EOF 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); 407EOF 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"; 426EOF 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"; 438EOF 439 "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800] 440 441 unless ($have_strtod) { 442 skip("no strtod()", 1); 443 } 444 else { 445 fresh_perl_is(<<"EOF", 446 use POSIX; 447 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma"); 448 my \$one_point_5 = POSIX::strtod("1,5"); 449 \$one_point_5 =~ s/0+\$//; # Remove any trailing zeros 450 print \$one_point_5, "\n"; 451EOF 452 "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale"); 453 } 454 } 455 } 456 457 { 458 my @valid_categories = valid_locale_categories(); 459 460 my $valid_string = ""; 461 my $invalid_string = ""; 462 463 # Deliberately don't include all categories, so as to test this situation 464 for my $i (0 .. @valid_categories - 2) { 465 my $category = $valid_categories[$i]; 466 if ($category ne "LC_ALL") { 467 $invalid_string .= ";" if $invalid_string ne ""; 468 $invalid_string .= "$category=foo_BAR"; 469 470 next unless $non_C_locale; 471 $valid_string .= ";" if $valid_string ne ""; 472 $valid_string .= "$category=$non_C_locale"; 473 } 474 } 475 476 fresh_perl(<<"EOF", 477 use locale; 478 use POSIX; 479 POSIX::setlocale(LC_ALL, "$invalid_string"); 480EOF 481 {}); 482 is ($?, 0, "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'"); 483 484 skip("no non-C locale available", 1 ) unless $non_C_locale; 485 fresh_perl(<<"EOF", 486 use locale; 487 use POSIX; 488 POSIX::setlocale(LC_ALL, "$valid_string"); 489EOF 490 {}); 491 is ($?, 0, "In setting complicated valid LC_ALL, final individ category doesn't need a \';'"); 492 493 } 494 495} 496 497done_testing(); 498