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; 10use warnings; 11 12######## 13# These tests are here instead of lib/locale.t because 14# some bugs depend on the internal state of the locale 15# settings and pragma/locale messes up that state pretty badly. 16# We need "fresh runs". 17BEGIN { 18 eval { require POSIX; POSIX->import("locale_h") }; 19 if ($@) { 20 skip_all("could not load the POSIX module"); # running minitest? 21 } 22} 23use Config; 24 25if ($^O eq "aix" && ($Config{osvers} =~ /^(\d+)/)[0] < 7) { 26 # https://www.ibm.com/support/pages/apar/IV22174 27 skip_all("old AIX setlocale is broken in some cases"); 28} 29 30use I18N::Langinfo qw(langinfo RADIXCHAR); 31my $have_strtod = $Config{d_strtod} eq 'define'; 32my $have_localeconv = defined $Config{d_locconv} && $Config{d_locconv} eq 'define'; 33my @locales = find_locales( [ 'LC_ALL', 'LC_CTYPE', 'LC_NUMERIC' ]); 34skip_all("no locales available") unless @locales; 35note("locales available: @locales"); 36 37my $debug = 0; 38my $switches = ""; 39if (defined $ARGV[0] && $ARGV[0] ne "") { 40 if ($ARGV[0] ne 'debug') { 41 print STDERR "Usage: $0 [ debug ]\n"; 42 exit 1 43 } 44 $debug = 1; 45} 46$switches = "switches => [ '-DLv' ]" if $debug; 47 48# reset the locale environment 49delete local @ENV{'LANGUAGE', 'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)}; 50 51# If user wants this to happen, they set the environment variable AND use 52# 'debug' 53delete local $ENV{'PERL_DEBUG_LOCALE_INIT'} unless $debug; 54 55{ 56 fresh_perl_is(<<"EOF", 57 use locale; 58 use POSIX; 59 POSIX::setlocale(POSIX::LC_CTYPE(),"C"); 60 print "h" =~ /[g\\w]/i || 0; 61 print "\\n"; 62EOF 63 1, { stderr => 'devnull' }, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char"); 64} 65 66{ 67 fresh_perl_is(<<"EOF", 68 use locale; 69 use POSIX; 70 POSIX::setlocale(POSIX::LC_CTYPE(),"C"); 71 print "0" =~ /[\\d[:punct:]]/l || 0; 72 print "\\n"; 73EOF 74 1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class"); 75 76} 77 78my $non_C_locale; 79foreach my $locale (@locales) { 80 next if $locale eq "C" || $locale eq 'POSIX' || $locale eq "C.UTF-8"; 81 $non_C_locale = $locale; 82 last; 83} 84 85if ($non_C_locale) { 86 note("using non-C locale '$non_C_locale'"); 87 setlocale(LC_NUMERIC, $non_C_locale); 88 isnt(setlocale(LC_NUMERIC), "C", "retrieving current non-C LC_NUMERIC doesn't give 'C'"); 89 setlocale(LC_ALL, $non_C_locale); 90 isnt(setlocale(LC_ALL), "C", "retrieving current non-C LC_ALL doesn't give 'C'"); 91 92 my @test_numeric_locales = @locales; 93 94 # Skip this locale on these cygwin versions as the returned radix character 95 # length is wrong 96 if ( $^O eq 'cygwin' 97 && version->new(($Config{'osvers'} =~ /^(\d+(?:\.\d+)+)/)[0]) le v2.4.1) 98 { 99 @test_numeric_locales = grep { $_ !~ m/ps_AF/i } @test_numeric_locales; 100 } 101 102 # Similarly the arabic locales on solaris don't work right on the 103 # multi-byte radix character, generating malformed UTF-8. 104 if ($^O eq 'solaris') { 105 @test_numeric_locales = grep { $_ !~ m/ ^ ( ar_ | pa_ ) /x } 106 @test_numeric_locales; 107 } 108 109 fresh_perl_is("for (qw(@test_numeric_locales)) {\n" . <<'EOF', 110 use POSIX qw(locale_h); 111 use locale; 112 setlocale(LC_NUMERIC, "$_") or next; 113 my $s = sprintf "%g %g", 3.1, 3.1; 114 next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; 115 no warnings "utf8"; 116 print "$_ $s\n"; 117 } 118EOF 119 "", { eval $switches }, "no locales where LC_NUMERIC breaks"); 120 121 SKIP: { 122 skip("Windows stores locale defaults in the registry", 1 ) 123 if $^O eq 'MSWin32'; 124 fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF', 125 use POSIX qw(locale_h); 126 use locale; 127 my $in = 4.2; 128 my $s = sprintf "%g", $in; # avoid any constant folding bugs 129 next if $s eq "4.2"; 130 no warnings "utf8"; 131 print "$_ $s\n"; 132 } 133EOF 134 "", { eval $switches }, "LC_NUMERIC without environment nor setlocale() has no effect in any locale"); 135 } 136 137 # try to find out a locale where LC_NUMERIC makes a difference 138 my $original_locale = setlocale(LC_NUMERIC); 139 140 my ($base, $different, $comma, $difference, $utf8_radix); 141 my $radix_encoded_as_utf8; 142 for ("C", @locales) { # prefer C for the base if available 143 use locale; 144 setlocale(LC_NUMERIC, $_) or next; 145 my $in = 4.2; # avoid any constant folding bugs 146 if ((my $s = sprintf("%g", $in)) eq "4.2") { 147 $base ||= $_; 148 } else { 149 $different ||= $_; 150 $difference ||= $s; 151 my $radix = langinfo(RADIXCHAR); 152 153 # For utf8 locales with a non-ascii radix, it should be encoded as 154 # UTF-8 with the internal flag so set. 155 if (! defined $utf8_radix 156 && $radix =~ /[[:^ascii:]]/u # /u because /l can raise warnings 157 && is_locale_utf8($_)) 158 { 159 $utf8_radix = $_; 160 $radix_encoded_as_utf8 = utf8::is_utf8($radix); 161 } 162 else { 163 $comma ||= $_ if $radix eq ','; 164 } 165 } 166 167 last if $base && $different && $comma && $utf8_radix; 168 } 169 setlocale(LC_NUMERIC, $original_locale); 170 171 SKIP: { 172 skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 ) 173 unless $utf8_radix; 174 is($radix_encoded_as_utf8, 1, "UTF-8 locale '$utf8_radix' with non-ASCII" 175 . " radix is marked UTF-8"); 176 } 177 178 SKIP: { 179 skip("no locale available where LC_NUMERIC radix isn't '.'", 30) unless $different; 180 note("using the '$different' locale for LC_NUMERIC tests"); 181 { 182 local $ENV{LC_NUMERIC} = $different; 183 184 fresh_perl_is(<<'EOF', "4.2", { eval $switches }, 185 format STDOUT = 186@.# 1874.179 188. 189 write; 190EOF 191 "format() does not look at LC_NUMERIC without 'use locale'"); 192 193 { 194 fresh_perl_is(<<'EOF', "$difference\n", { eval $switches }, 195 use POSIX; 196 use locale; 197 format STDOUT = 198@.# 1994.179 200. 201 write; 202EOF 203 "format() looks at LC_NUMERIC with 'use locale'"); 204 } 205 206 SKIP: { 207 unless ($have_localeconv) { 208 skip("no localeconv()", 1); 209 } 210 else { 211 fresh_perl_is(<<'EOF', ",,", { eval $switches }, 212 use POSIX; 213 no warnings "utf8"; 214 print localeconv()->{decimal_point}; 215 use locale; 216 print localeconv()->{decimal_point}; 217EOF 218 "localeconv() looks at LC_NUMERIC with and without 'use locale'"); 219 } 220 } 221 222 { 223 my $categories = ":collate :characters :collate :ctype :monetary :time"; 224 fresh_perl_is(<<"EOF", "4.2", { eval $switches }, 225 use locale qw($categories); 226 format STDOUT = 227@.# 2284.179 229. 230 write; 231EOF 232 "format() does not look at LC_NUMERIC with 'use locale qw($categories)'"); 233 } 234 235 { 236 fresh_perl_is(<<'EOF', $difference, { eval $switches }, 237 use locale; 238 format STDOUT = 239@.# 2404.179 241. 242 write; 243EOF 244 "format() looks at LC_NUMERIC with 'use locale'"); 245 } 246 247 for my $category (qw(collate characters collate ctype monetary time)) { 248 for my $negation ("!", "not_") { 249 fresh_perl_is(<<"EOF", $difference, { eval $switches }, 250 use locale ":$negation$category"; 251format STDOUT = 252@.# 2534.179 254. 255 write; 256EOF 257 "format() looks at LC_NUMERIC with 'use locale \":" 258 . "$negation$category\"'"); 259 } 260 } 261 262 { 263 fresh_perl_is(<<'EOF', $difference, { eval $switches }, 264 use locale ":numeric"; 265format STDOUT = 266@.# 2674.179 268. 269 write; 270EOF 271 "format() looks at LC_NUMERIC with 'use locale \":numeric\"'"); 272 } 273 274 { 275 fresh_perl_is(<<'EOF', "4.2", { eval $switches }, 276format STDOUT = 277@.# 2784.179 279. 280 { use locale; write; } 281EOF 282 "too late to look at the locale at write() time"); 283 } 284 285 { 286 fresh_perl_is(<<'EOF', $difference, { eval $switches }, 287 use locale; 288 format STDOUT = 289@.# 2904.179 291. 292 { no locale; write; } 293EOF 294 "too late to ignore the locale at write() time"); 295 } 296 } 297 298 { 299 # do not let "use 5.000" affect the locale! 300 # this test is to prevent regression of [rt.perl.org #105784] 301 fresh_perl_is(<<"EOF", 302 use locale; 303 use POSIX; 304 my \$i = 0.123; 305 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different"); 306 \$a = sprintf("%.2f", \$i); 307 require version; 308 \$b = sprintf("%.2f", \$i); 309 no warnings "utf8"; 310 print ".\$a \$b" unless \$a eq \$b 311EOF 312 "", { eval $switches }, "version does not clobber version"); 313 314 fresh_perl_is(<<"EOF", 315 use locale; 316 use POSIX; 317 my \$i = 0.123; 318 POSIX::setlocale(POSIX::LC_NUMERIC(),"$different"); 319 \$a = sprintf("%.2f", \$i); 320 eval "use v5.0.0"; 321 \$b = sprintf("%.2f", \$i); 322 no warnings "utf8"; 323 print "\$a \$b" unless \$a eq \$b 324EOF 325 "", { eval $switches }, "version does not clobber version (via eval)"); 326 } 327 328 { 329 local $ENV{LC_NUMERIC} = $different; 330 fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches }, 331 use locale; 332 use POSIX qw(locale_h); 333 my $in = 4.2; 334 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2)); 335EOF 336 "sprintf() and printf() look at LC_NUMERIC regardless of constant folding"); 337 } 338 339 { 340 local $ENV{LC_NUMERIC} = $different; 341 fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches }, 342 use locale; 343 use POSIX qw(locale_h); 344 my $in = 4.2; 345 printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2)); 346EOF 347 "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC"); 348 } 349 350 351 # within this block, STDERR is closed. This is because fresh_perl_is() 352 # forks a shell, and some shells (like bash) can complain noisily when 353 # LC_ALL or similar is set to an invalid value 354 355 { 356 open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!"; 357 close STDERR; 358 359 { 360 local $ENV{LC_ALL} = "invalid"; 361 local $ENV{LC_NUMERIC} = "invalid"; 362 local $ENV{LANG} = $different; 363 local $ENV{PERL_BADLANG} = 0; 364 365 if (! fresh_perl_is(<<"EOF", "$difference", { eval $switches }, 366 if (\$ENV{LC_ALL} ne "invalid") { 367 # Make the test pass if the sh didn't accept the ENV set 368 no warnings "utf8"; 369 print "$difference\n"; 370 exit 0; 371 } 372 use locale; 373 use POSIX qw(locale_h); 374 my \$in = 4.2; 375 printf("%g", \$in); 376EOF 377 "LANG is used if LC_ALL, LC_NUMERIC are invalid")) 378 { 379 note "To see details change this .t, do not close STDERR"; 380 } 381 } 382 383 SKIP: { 384 if ($^O eq 'MSWin32') { 385 skip("Win32 uses system default locale in preference to \"C\"", 386 1); 387 } 388 else { 389 local $ENV{LC_ALL} = "invalid"; 390 local $ENV{LC_NUMERIC} = "invalid"; 391 local $ENV{LANG} = "invalid"; 392 local $ENV{PERL_BADLANG} = 0; 393 394 if (! fresh_perl_is(<<"EOF", 4.2, { eval $switches }, 395 if (\$ENV{LC_ALL} ne "invalid") { 396 no warnings "utf8"; 397 print "$difference\n"; 398 exit 0; 399 } 400 use locale; 401 use POSIX qw(locale_h); 402 my \$in = 4.2; 403 printf("%g", \$in); 404EOF 405 'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid')) 406 { 407 note "To see details change this .t, do not close STDERR"; 408 } 409 } 410 } 411 412 open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!"; 413 } 414 415 { 416 local $ENV{LC_NUMERIC} = $different; 417 fresh_perl_is(<<"EOF", 418 use POSIX qw(locale_h); 419 420 BEGIN { setlocale(LC_NUMERIC, \"$different\"); }; 421 setlocale(LC_ALL, "C"); 422 use 5.008; 423 print setlocale(LC_NUMERIC); 424EOF 425 "C", { stderr => 'devnull' }, 426 "No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix"); 427 } 428 429 unless ($comma) { 430 skip("no locale available where LC_NUMERIC is a comma", 3); 431 } 432 else { 433 434 fresh_perl_is(<<"EOF", 435 my \$i = 1.5; 436 { 437 use locale; 438 use POSIX; 439 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma"); 440 print \$i, "\n"; 441 } 442 print \$i, "\n"; 443EOF 444 "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without"); 445 446 fresh_perl_is(<<"EOF", 447 my \$i = 1.5; # Should be exactly representable as a base 2 448 # fraction, so can use 'eq' below 449 use locale; 450 use POSIX; 451 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma"); 452 print \$i, "\n"; 453 \$i += 1; 454 print \$i, "\n"; 455EOF 456 "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800] 457 458 SKIP: { 459 skip "Perl not compiled with 'useithreads'", 1 if ! $Config{'useithreads'}; 460 461 local $ENV{LC_ALL} = undef; 462 local $ENV{LC_NUMERIC} = $comma; 463 fresh_perl_is(<<"EOF", 464 use threads; 465 466 my \$x = eval "1.25"; 467 print "\$x", "\n"; # number is ok before thread 468 my \$str_x = "\$x"; 469 470 my \$thr = threads->create(sub {}); 471 \$thr->join(); 472 473 print "\$x\n"; # number stringifies the same after thread 474 475 my \$y = eval "1.25"; 476 print "\$y\n"; # number is ok after threads 477 print "\$y" eq "\$str_x" || 0; # new number stringifies the same as old number 478EOF 479 "1.25\n1.25\n1.25\n1", { eval $switches }, "Thread join doesn't disrupt calling thread" 480 ); # [GH 20155] 481 } 482 483 SKIP: { 484 unless ($have_strtod) { 485 skip("no strtod()", 1); 486 } 487 else { 488 fresh_perl_is(<<"EOF", 489 use POSIX; 490 POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma"); 491 my \$one_point_5 = POSIX::strtod("1,5"); 492 \$one_point_5 =~ s/0+\$//; # Remove any trailing zeros 493 print \$one_point_5, "\n"; 494EOF 495 "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale"); 496 } 497 } 498 } 499 } 500 501SKIP: { 502 # Note: the setlocale Configure probe could be enhanced to give us the 503 # syntax to use, but khw doesn't think it's worth it at this time, as 504 # the current outliers seem to be skipped by the test just below 505 # anyway. If the POSIX 2008 locale functions are being used, the 506 # syntax becomes mostly irrelevant, so do the test anyway if they are. 507 # It's a lot of trouble to figure out in a perl script. 508 if ($Config{d_setlocale_accepts_any_locale_name}) 509 { 510 skip("Can't distinguish between valid and invalid locale names on this system", 2); 511 } 512 513 my @valid_categories = valid_locale_categories(); 514 515 my $valid_string = ""; 516 my $invalid_string = ""; 517 518 # Deliberately don't include all categories, so as to test this situation 519 for my $i (0 .. @valid_categories - 2) { 520 my $category = $valid_categories[$i]; 521 if ($category ne "LC_ALL") { 522 $invalid_string .= ";" if $invalid_string ne ""; 523 $invalid_string .= "$category=foo_BAR"; 524 525 next unless $non_C_locale; 526 $valid_string .= ";" if $valid_string ne ""; 527 $valid_string .= "$category=$non_C_locale"; 528 } 529 } 530 531 fresh_perl_is(<<"EOF", 532 use locale; 533 use POSIX; 534 POSIX::setlocale(LC_ALL, "$invalid_string"); 535EOF 536 "", { eval $switches }, 537 "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'"); 538 539 skip("no non-C locale available", 1 ) unless $non_C_locale; 540 fresh_perl_is(<<"EOF", 541 use locale; 542 use POSIX; 543 POSIX::setlocale(LC_ALL, "$valid_string"); 544EOF 545 "", { eval $switches }, 546 "In setting complicated valid LC_ALL, final individ category doesn't need a \';'"); 547 } 548 549} 550 551SKIP: 552{ 553 use locale; 554 # look for an english locale (so a < B, hopefully) 555 my ($en) = grep { /^en_/ } find_locales( [ 'LC_COLLATE' ]); 556 defined $en 557 or skip "didn't find a suitable locale", 1; 558 POSIX::setlocale(LC_COLLATE, $en); 559 unless ("a" lt "B") { 560 skip "didn't find a suitable locale", 1; 561 } 562 fresh_perl_is(<<'EOF', "ok\n", { args => [ $en ] }, "check for failed assertion"); 563use locale ':collate'; 564use POSIX qw(setlocale LC_COLLATE); 565if (setlocale(LC_COLLATE, shift)) { 566 my $x = "a"; 567 my $y = "B"; 568 print $x lt $y ? "ok\n" : "not ok\n"; 569 $x = "c"; # should empty the collxfrm magic but not remove it 570 # which the free code asserts on 571} 572else { 573 print "ok\n"; 574} 575EOF 576} 577 578SKIP: { # GH #20085 579 my @utf8_locales = find_utf8_ctype_locales(); 580 skip "didn't find a UTF-8 locale", 1 unless @utf8_locales; 581 582 local $ENV{LC_CTYPE} = $utf8_locales[0]; 583 local $ENV{LC_ALL} = undef; 584 fresh_perl_is(<<~'EOF', "ok\n", {}, "check that setlocale overrides startup"); 585 use POSIX; 586 587 my $a_acute = "\N{LATIN SMALL LETTER A WITH ACUTE}"; 588 my $egrave = "\N{LATIN SMALL LETTER E WITH GRAVE}"; 589 my $combo = "$a_acute.$egrave"; 590 591 setlocale(&POSIX::LC_ALL, "C"); 592 use locale; 593 594 # In a UTF-8 locale, \b matches Latin1 before string, mid, and end 595 if ($combo eq ($combo =~ s/\b/!/gr)) { 596 print "ok\n"; 597 } 598 else { 599 print "not ok\n"; 600 } 601 EOF 602} 603 604SKIP: { # GH #20054 605 skip "Even illegal locale names are accepted", 1 606 if $Config{d_setlocale_accepts_any_locale_name} 607 && $Config{d_setlocale_accepts_any_locale_name} eq 'define'; 608 609 my @lc_all_locales = find_locales('LC_ALL'); 610 my $locale = $lc_all_locales[0]; 611 skip "LC_ALL not enabled on this platform", 1 unless $locale; 612 613 local $ENV{LC_ALL} = "This is not a legal locale name"; 614 local $ENV{LANG} = "Nor this neither"; 615 616 my $fallback = ($^O eq "MSWin32") 617 ? "system default" 618 : "standard"; 619 fresh_perl_like("", qr/Falling back to the $fallback locale/, 620 {}, "check that illegal startup environment falls back"); 621} 622 623done_testing(); 624