1#!./perl -wT 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 unshift @INC, '.'; 7 require Config; import Config; 8 if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { 9 print "1..0\n"; 10 exit; 11 } 12 $| = 1; 13} 14 15use strict; 16 17my $debug = 1; 18 19use Dumpvalue; 20 21my $dumper = Dumpvalue->new( 22 tick => qq{"}, 23 quoteHighBit => 0, 24 unctrl => "quote" 25 ); 26sub debug { 27 return unless $debug; 28 my($mess) = join "", @_; 29 chop $mess; 30 print $dumper->stringify($mess,1), "\n"; 31} 32 33sub debugf { 34 printf @_ if $debug; 35} 36 37my $have_setlocale = 0; 38eval { 39 require POSIX; 40 import POSIX ':locale_h'; 41 $have_setlocale++; 42}; 43 44# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" 45# and mingw32 uses said silly CRT 46$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); 47 48# UWIN seems to loop after test 98, just skip for now 49$have_setlocale = 0 if ($^O =~ /^uwin/); 50 51my $last = $have_setlocale ? &last : &last_without_setlocale; 52 53print "1..$last\n"; 54 55use vars qw(&LC_ALL); 56 57$a = 'abc %'; 58 59sub ok { 60 my ($n, $result) = @_; 61 62 print 'not ' unless ($result); 63 print "ok $n\n"; 64} 65 66# First we'll do a lot of taint checking for locales. 67# This is the easiest to test, actually, as any locale, 68# even the default locale will taint under 'use locale'. 69 70sub is_tainted { # hello, camel two. 71 no warnings 'uninitialized' ; 72 my $dummy; 73 not eval { $dummy = join("", @_), kill 0; 1 } 74} 75 76sub check_taint ($$) { 77 ok $_[0], is_tainted($_[1]); 78} 79 80sub check_taint_not ($$) { 81 ok $_[0], not is_tainted($_[1]); 82} 83 84use locale; # engage locale and therefore locale taint. 85 86check_taint_not 1, $a; 87 88check_taint 2, uc($a); 89check_taint 3, "\U$a"; 90check_taint 4, ucfirst($a); 91check_taint 5, "\u$a"; 92check_taint 6, lc($a); 93check_taint 7, "\L$a"; 94check_taint 8, lcfirst($a); 95check_taint 9, "\l$a"; 96 97check_taint_not 10, sprintf('%e', 123.456); 98check_taint_not 11, sprintf('%f', 123.456); 99check_taint_not 12, sprintf('%g', 123.456); 100check_taint_not 13, sprintf('%d', 123.456); 101check_taint_not 14, sprintf('%x', 123.456); 102 103$_ = $a; # untaint $_ 104 105$_ = uc($a); # taint $_ 106 107check_taint 15, $_; 108 109/(\w)/; # taint $&, $`, $', $+, $1. 110check_taint 16, $&; 111check_taint 17, $`; 112check_taint 18, $'; 113check_taint 19, $+; 114check_taint 20, $1; 115check_taint_not 21, $2; 116 117/(.)/; # untaint $&, $`, $', $+, $1. 118check_taint_not 22, $&; 119check_taint_not 23, $`; 120check_taint_not 24, $'; 121check_taint_not 25, $+; 122check_taint_not 26, $1; 123check_taint_not 27, $2; 124 125/(\W)/; # taint $&, $`, $', $+, $1. 126check_taint 28, $&; 127check_taint 29, $`; 128check_taint 30, $'; 129check_taint 31, $+; 130check_taint 32, $1; 131check_taint_not 33, $2; 132 133/(\s)/; # taint $&, $`, $', $+, $1. 134check_taint 34, $&; 135check_taint 35, $`; 136check_taint 36, $'; 137check_taint 37, $+; 138check_taint 38, $1; 139check_taint_not 39, $2; 140 141/(\S)/; # taint $&, $`, $', $+, $1. 142check_taint 40, $&; 143check_taint 41, $`; 144check_taint 42, $'; 145check_taint 43, $+; 146check_taint 44, $1; 147check_taint_not 45, $2; 148 149$_ = $a; # untaint $_ 150 151check_taint_not 46, $_; 152 153/(b)/; # this must not taint 154check_taint_not 47, $&; 155check_taint_not 48, $`; 156check_taint_not 49, $'; 157check_taint_not 50, $+; 158check_taint_not 51, $1; 159check_taint_not 52, $2; 160 161$_ = $a; # untaint $_ 162 163check_taint_not 53, $_; 164 165$b = uc($a); # taint $b 166s/(.+)/$b/; # this must taint only the $_ 167 168check_taint 54, $_; 169check_taint_not 55, $&; 170check_taint_not 56, $`; 171check_taint_not 57, $'; 172check_taint_not 58, $+; 173check_taint_not 59, $1; 174check_taint_not 60, $2; 175 176$_ = $a; # untaint $_ 177 178s/(.+)/b/; # this must not taint 179check_taint_not 61, $_; 180check_taint_not 62, $&; 181check_taint_not 63, $`; 182check_taint_not 64, $'; 183check_taint_not 65, $+; 184check_taint_not 66, $1; 185check_taint_not 67, $2; 186 187$b = $a; # untaint $b 188 189($b = $a) =~ s/\w/$&/; 190check_taint 68, $b; # $b should be tainted. 191check_taint_not 69, $a; # $a should be not. 192 193$_ = $a; # untaint $_ 194 195s/(\w)/\l$1/; # this must taint 196check_taint 70, $_; 197check_taint 71, $&; 198check_taint 72, $`; 199check_taint 73, $'; 200check_taint 74, $+; 201check_taint 75, $1; 202check_taint_not 76, $2; 203 204$_ = $a; # untaint $_ 205 206s/(\w)/\L$1/; # this must taint 207check_taint 77, $_; 208check_taint 78, $&; 209check_taint 79, $`; 210check_taint 80, $'; 211check_taint 81, $+; 212check_taint 82, $1; 213check_taint_not 83, $2; 214 215$_ = $a; # untaint $_ 216 217s/(\w)/\u$1/; # this must taint 218check_taint 84, $_; 219check_taint 85, $&; 220check_taint 86, $`; 221check_taint 87, $'; 222check_taint 88, $+; 223check_taint 89, $1; 224check_taint_not 90, $2; 225 226$_ = $a; # untaint $_ 227 228s/(\w)/\U$1/; # this must taint 229check_taint 91, $_; 230check_taint 92, $&; 231check_taint 93, $`; 232check_taint 94, $'; 233check_taint 95, $+; 234check_taint 96, $1; 235check_taint_not 97, $2; 236 237# After all this tainting $a should be cool. 238 239check_taint_not 98, $a; 240 241sub last_without_setlocale { 98 } 242 243# I think we've seen quite enough of taint. 244# Let us do some *real* locale work now, 245# unless setlocale() is missing (i.e. minitest). 246 247exit unless $have_setlocale; 248 249# Find locales. 250 251debug "# Scanning for locales...\n"; 252 253# Note that it's okay that some languages have their native names 254# capitalized here even though that's not "right". They are lowercased 255# anyway later during the scanning process (and besides, some clueless 256# vendor might have them capitalized errorneously anyway). 257 258my $locales = <<EOF; 259Afrikaans:af:za:1 15 260Arabic:ar:dz eg sa:6 arabic8 261Brezhoneg Breton:br:fr:1 15 262Bulgarski Bulgarian:bg:bg:5 263Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC 264Hrvatski Croatian:hr:hr:2 265Cymraeg Welsh:cy:cy:1 14 15 266Czech:cs:cz:2 267Dansk Danish:dk:da:1 15 268Nederlands Dutch:nl:be nl:1 15 269English American British:en:au ca gb ie nz us uk zw:1 15 cp850 270Esperanto:eo:eo:3 271Eesti Estonian:et:ee:4 6 13 272Suomi Finnish:fi:fi:1 15 273Flamish::fl:1 15 274Deutsch German:de:at be ch de lu:1 15 275Euskaraz Basque:eu:es fr:1 15 276Galego Galician:gl:es:1 15 277Ellada Greek:el:gr:7 g8 278Frysk:fy:nl:1 15 279Greenlandic:kl:gl:4 6 280Hebrew:iw:il:8 hebrew8 281Hungarian:hu:hu:2 282Indonesian:in:id:1 15 283Gaeilge Irish:ga:IE:1 14 15 284Italiano Italian:it:ch it:1 15 285Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis 286Korean:ko:kr: 287Latine Latin:la:va:1 15 288Latvian:lv:lv:4 6 13 289Lithuanian:lt:lt:4 6 13 290Macedonian:mk:mk:1 15 291Maltese:mt:mt:3 292Moldovan:mo:mo:2 293Norsk Norwegian:no no\@nynorsk:no:1 15 294Occitan:oc:es:1 15 295Polski Polish:pl:pl:2 296Rumanian:ro:ro:2 297Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866 298Serbski Serbian:sr:yu:5 299Slovak:sk:sk:2 300Slovene Slovenian:sl:si:2 301Sqhip Albanian:sq:sq:1 15 302Svenska Swedish:sv:fi se:1 15 303Thai:th:th:11 tis620 304Turkish:tr:tr:9 turkish8 305Yiddish:yi::1 15 306EOF 307 308if ($^O eq 'os390') { 309 # These cause heartburn. Broken locales? 310 $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; 311 $locales =~ s/Thai:th:th:11 tis620\n//; 312} 313 314sub in_utf8 () { $^H & 0x08 || (${^OPEN} || "") =~ /:utf8/ } 315 316if (in_utf8) { 317 require "lib/locale/utf8"; 318} else { 319 require "lib/locale/latin1"; 320} 321 322my @Locale; 323my $Locale; 324my @Alnum_; 325 326my @utf8locale; 327my %utf8skip; 328 329sub getalnum_ { 330 sort grep /\w/, map { chr } 0..255 331} 332 333sub trylocale { 334 my $locale = shift; 335 if (setlocale(LC_ALL, $locale)) { 336 push @Locale, $locale; 337 } 338} 339 340sub decode_encodings { 341 my @enc; 342 343 foreach (split(/ /, shift)) { 344 if (/^(\d+)$/) { 345 push @enc, "ISO8859-$1"; 346 push @enc, "iso8859$1"; # HP 347 if ($1 eq '1') { 348 push @enc, "roman8"; # HP 349 } 350 } else { 351 push @enc, $_; 352 push @enc, "$_.UTF-8"; 353 } 354 } 355 if ($^O eq 'os390') { 356 push @enc, qw(IBM-037 IBM-819 IBM-1047); 357 } 358 359 return @enc; 360} 361 362trylocale("C"); 363trylocale("POSIX"); 364foreach (0..15) { 365 trylocale("ISO8859-$_"); 366 trylocale("iso8859$_"); 367 trylocale("iso8859-$_"); 368 trylocale("iso_8859_$_"); 369 trylocale("isolatin$_"); 370 trylocale("isolatin-$_"); 371 trylocale("iso_latin_$_"); 372} 373 374# Sanitize the environment so that we can run the external 'locale' 375# program without the taint mode getting grumpy. 376 377# $ENV{PATH} is special in VMS. 378delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv}; 379 380# Other subversive stuff. 381delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; 382 383if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { 384 while (<LOCALES>) { 385 chomp; 386 trylocale($_); 387 } 388 close(LOCALES); 389} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { 390# The SYS$I18N_LOCALE logical name search list was not present on 391# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. 392 opendir(LOCALES, "SYS\$I18N_LOCALE:"); 393 while ($_ = readdir(LOCALES)) { 394 chomp; 395 trylocale($_); 396 } 397 close(LOCALES); 398} else { 399 400 # This is going to be slow. 401 402 foreach my $locale (split(/\n/, $locales)) { 403 my ($locale_name, $language_codes, $country_codes, $encodings) = 404 split(/:/, $locale); 405 my @enc = decode_encodings($encodings); 406 foreach my $loc (split(/ /, $locale_name)) { 407 trylocale($loc); 408 foreach my $enc (@enc) { 409 trylocale("$loc.$enc"); 410 } 411 $loc = lc $loc; 412 foreach my $enc (@enc) { 413 trylocale("$loc.$enc"); 414 } 415 } 416 foreach my $lang (split(/ /, $language_codes)) { 417 trylocale($lang); 418 foreach my $country (split(/ /, $country_codes)) { 419 my $lc = "${lang}_${country}"; 420 trylocale($lc); 421 foreach my $enc (@enc) { 422 trylocale("$lc.$enc"); 423 } 424 my $lC = "${lang}_\U${country}"; 425 trylocale($lC); 426 foreach my $enc (@enc) { 427 trylocale("$lC.$enc"); 428 } 429 } 430 } 431 } 432} 433 434setlocale(LC_ALL, "C"); 435 436@Locale = sort @Locale; 437 438debug "# Locales =\n"; 439for ( @Locale ) { 440 debug "# $_\n"; 441} 442 443my %Problem; 444my %Okay; 445my %Testing; 446my @Neoalpha; 447my %Neoalpha; 448 449sub tryneoalpha { 450 my ($Locale, $i, $test) = @_; 451 unless ($test) { 452 $Problem{$i}{$Locale} = 1; 453 debug "# failed $i with locale '$Locale'\n"; 454 } else { 455 push @{$Okay{$i}}, $Locale; 456 } 457} 458 459foreach $Locale (@Locale) { 460 debug "# Locale = $Locale\n"; 461 @Alnum_ = getalnum_(); 462 debug "# w = ", join("",@Alnum_), "\n"; 463 464 unless (setlocale(LC_ALL, $Locale)) { 465 foreach (99..103) { 466 $Problem{$_}{$Locale} = -1; 467 } 468 next; 469 } 470 471 # Sieve the uppercase and the lowercase. 472 473 my %UPPER = (); 474 my %lower = (); 475 my %BoThCaSe = (); 476 for (@Alnum_) { 477 if (/[^\d_]/) { # skip digits and the _ 478 if (uc($_) eq $_) { 479 $UPPER{$_} = $_; 480 } 481 if (lc($_) eq $_) { 482 $lower{$_} = $_; 483 } 484 } 485 } 486 foreach (keys %UPPER) { 487 $BoThCaSe{$_}++ if exists $lower{$_}; 488 } 489 foreach (keys %lower) { 490 $BoThCaSe{$_}++ if exists $UPPER{$_}; 491 } 492 foreach (keys %BoThCaSe) { 493 delete $UPPER{$_}; 494 delete $lower{$_}; 495 } 496 497 debug "# UPPER = ", join("", sort keys %UPPER ), "\n"; 498 debug "# lower = ", join("", sort keys %lower ), "\n"; 499 debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n"; 500 501 # Find the alphabets that are not alphabets in the default locale. 502 503 { 504 no locale; 505 506 @Neoalpha = (); 507 for (keys %UPPER, keys %lower) { 508 push(@Neoalpha, $_) if (/\W/); 509 $Neoalpha{$_} = $_; 510 } 511 } 512 513 @Neoalpha = sort @Neoalpha; 514 515 debug "# Neoalpha = ", join("",@Neoalpha), "\n"; 516 517 if (@Neoalpha == 0) { 518 # If we have no Neoalphas the remaining tests are no-ops. 519 debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n"; 520 foreach (99..102) { 521 push @{$Okay{$_}}, $Locale; 522 } 523 } else { 524 525 # Test \w. 526 527 my $word = join('', @Neoalpha); 528 529 my $badutf8; 530 { 531 local $SIG{__WARN__} = sub { 532 $badutf8 = $_[0] =~ /Malformed UTF-8/; 533 }; 534 $Locale =~ /utf-?8/i; 535 } 536 537 if ($badutf8) { 538 debug "# Locale name contains bad UTF-8, skipping test 99 for locale '$Locale'\n"; 539 } elsif ($Locale =~ /utf-?8/i) { 540 debug "# unknown whether locale and Unicode have the same \\w, skipping test 99 for locale '$Locale'\n"; 541 push @{$Okay{99}}, $Locale; 542 } else { 543 if ($word =~ /^(\w+)$/) { 544 tryneoalpha($Locale, 99, 1); 545 } else { 546 tryneoalpha($Locale, 99, 0); 547 } 548 } 549 550 # Cross-check the whole 8-bit character set. 551 552 for (map { chr } 0..255) { 553 tryneoalpha($Locale, 100, 554 (/\w/ xor /\W/) || 555 (/\d/ xor /\D/) || 556 (/\s/ xor /\S/)); 557 } 558 559 # Test for read-only scalars' locale vs non-locale comparisons. 560 561 { 562 no locale; 563 $a = "qwerty"; 564 { 565 use locale; 566 tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0); 567 } 568 } 569 570 { 571 my ($from, $to, $lesser, $greater, 572 @test, %test, $test, $yes, $no, $sign); 573 574 for (0..9) { 575 # Select a slice. 576 $from = int(($_*@Alnum_)/10); 577 $to = $from + int(@Alnum_/10); 578 $to = $#Alnum_ if ($to > $#Alnum_); 579 $lesser = join('', @Alnum_[$from..$to]); 580 # Select a slice one character on. 581 $from++; $to++; 582 $to = $#Alnum_ if ($to > $#Alnum_); 583 $greater = join('', @Alnum_[$from..$to]); 584 ($yes, $no, $sign) = ($lesser lt $greater 585 ? (" ", "not ", 1) 586 : ("not ", " ", -1)); 587 # all these tests should FAIL (return 0). 588 # Exact lt or gt cannot be tested because 589 # in some locales, say, eacute and E may test equal. 590 @test = 591 ( 592 $no.' ($lesser le $greater)', # 1 593 'not ($lesser ne $greater)', # 2 594 ' ($lesser eq $greater)', # 3 595 $yes.' ($lesser ge $greater)', # 4 596 $yes.' ($lesser ge $greater)', # 5 597 $yes.' ($greater le $lesser )', # 7 598 'not ($greater ne $lesser )', # 8 599 ' ($greater eq $lesser )', # 9 600 $no.' ($greater ge $lesser )', # 10 601 'not (($lesser cmp $greater) == -($sign))' # 11 602 ); 603 @test{@test} = 0 x @test; 604 $test = 0; 605 for my $ti (@test) { 606 $test{$ti} = eval $ti; 607 $test ||= $test{$ti} 608 } 609 tryneoalpha($Locale, 102, $test == 0); 610 if ($test) { 611 debug "# lesser = '$lesser'\n"; 612 debug "# greater = '$greater'\n"; 613 debug "# lesser cmp greater = ", 614 $lesser cmp $greater, "\n"; 615 debug "# greater cmp lesser = ", 616 $greater cmp $lesser, "\n"; 617 debug "# (greater) from = $from, to = $to\n"; 618 for my $ti (@test) { 619 debugf("# %-40s %-4s", $ti, 620 $test{$ti} ? 'FAIL' : 'ok'); 621 if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { 622 debugf("(%s == %4d)", $1, eval $1); 623 } 624 debug "\n#"; 625 } 626 627 last; 628 } 629 } 630 } 631 } 632 633 use locale; 634 635 my ($x, $y) = (1.23, 1.23); 636 637 $a = "$x"; 638 printf ''; # printf used to reset locale to "C" 639 $b = "$y"; 640 641 debug "# 103..107: a = $a, b = $b, Locale = $Locale\n"; 642 643 tryneoalpha($Locale, 103, $a eq $b); 644 645 my $c = "$x"; 646 my $z = sprintf ''; # sprintf used to reset locale to "C" 647 my $d = "$y"; 648 649 debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; 650 651 tryneoalpha($Locale, 104, $c eq $d); 652 653 { 654 use warnings; 655 my $w = 0; 656 local $SIG{__WARN__} = 657 sub { 658 print "# @_\n"; 659 $w++; 660 }; 661 662 # The == (among other ops) used to warn for locales 663 # that had something else than "." as the radix character. 664 665 tryneoalpha($Locale, 105, $c == 1.23); 666 667 tryneoalpha($Locale, 106, $c == $x); 668 669 tryneoalpha($Locale, 107, $c == $d); 670 671 { 672# no locale; # XXX did this ever work correctly? 673 674 my $e = "$x"; 675 676 debug "# 108..110: e = $e, Locale = $Locale\n"; 677 678 tryneoalpha($Locale, 108, $e == 1.23); 679 680 tryneoalpha($Locale, 109, $e == $x); 681 682 tryneoalpha($Locale, 110, $e == $c); 683 } 684 685 my $f = "1.23"; 686 my $g = 2.34; 687 688 debug "# 111..115: f = $f, g = $g, locale = $Locale\n"; 689 690 tryneoalpha($Locale, 111, $f == 1.23); 691 692 tryneoalpha($Locale, 112, $f == $x); 693 694 tryneoalpha($Locale, 113, $f == $c); 695 696 tryneoalpha($Locale, 114, abs(($f + $g) - 3.57) < 0.01); 697 698 tryneoalpha($Locale, 115, $w == 0); 699 } 700 701 # Does taking lc separately differ from taking 702 # the lc "in-line"? (This was the bug 19990704.002, change #3568.) 703 # The bug was in the caching of the 'o'-magic. 704 { 705 use locale; 706 707 sub lcA { 708 my $lc0 = lc $_[0]; 709 my $lc1 = lc $_[1]; 710 return $lc0 cmp $lc1; 711 } 712 713 sub lcB { 714 return lc($_[0]) cmp lc($_[1]); 715 } 716 717 my $x = "ab"; 718 my $y = "aa"; 719 my $z = "AB"; 720 721 tryneoalpha($Locale, 116, 722 lcA($x, $y) == 1 && lcB($x, $y) == 1 || 723 lcA($x, $z) == 0 && lcB($x, $z) == 0); 724 } 725 726 # Does lc of an UPPER (if different from the UPPER) match 727 # case-insensitively the UPPER, and does the UPPER match 728 # case-insensitively the lc of the UPPER. And vice versa. 729 { 730 use locale; 731 no utf8; 732 my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/; 733 734 my @f = (); 735 foreach my $x (keys %UPPER) { 736 my $y = lc $x; 737 next unless uc $y eq $x; 738 print "# UPPER $x lc $y ", 739 $x =~ /$y/i ? 1 : 0, " ", 740 $y =~ /$x/i ? 1 : 0, "\n" if 0; 741 # 742 # If $x and $y contain regular expression characters 743 # AND THEY lowercase (/i) to regular expression characters, 744 # regcomp() will be mightily confused. No, the \Q doesn't 745 # help here (maybe regex engine internal lowercasing 746 # is done after the \Q?) An example of this happening is 747 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS): 748 # the chr(173) (the "[") is the lowercase of the chr(235). 749 # 750 # Similarly losing EBCDIC locales include cs_cz, cs_CZ, 751 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!), 752 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT, 753 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037, 754 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU, 755 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR. 756 # 757 # Similar things can happen even under (bastardised) 758 # non-EBCDIC locales: in many European countries before the 759 # advent of ISO 8859-x nationally customised versions of 760 # ISO 646 were devised, reusing certain punctuation 761 # characters for modified characters needed by the 762 # country/language. For example, the "|" might have 763 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS. 764 # 765 if ($x =~ $re || $y =~ $re) { 766 print "# Regex characters in '$x' or '$y', skipping test 117 for locale '$Locale'\n"; 767 next; 768 } 769 # With utf8 both will fail since the locale concept 770 # of upper/lower does not work well in Unicode. 771 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i; 772 773 foreach my $x (keys %lower) { 774 my $y = uc $x; 775 next unless lc $y eq $x; 776 print "# lower $x uc $y ", 777 $x =~ /$y/i ? 1 : 0, " ", 778 $y =~ /$x/i ? 1 : 0, "\n" if 0; 779 if ($x =~ $re || $y =~ $re) { # See above. 780 print "# Regex characters in '$x' or '$y', skipping test 117 for locale '$Locale'\n"; 781 next; 782 } 783 # With utf8 both will fail since the locale concept 784 # of upper/lower does not work well in Unicode. 785 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i; 786 } 787 tryneoalpha($Locale, 117, @f == 0); 788 if (@f) { 789 print "# failed 117 locale '$Locale' characters @f\n" 790 } 791 } 792 } 793} 794 795# Recount the errors. 796 797foreach (&last_without_setlocale()+1..$last) { 798 if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { 799 if ($_ == 102) { 800 print "# The failure of test 102 is not necessarily fatal.\n"; 801 print "# It usually indicates a problem in the environment,\n"; 802 print "# not in Perl itself.\n"; 803 } 804 print "not "; 805 } 806 print "ok $_\n"; 807} 808 809# Give final advice. 810 811my $didwarn = 0; 812 813foreach (99..$last) { 814 if ($Problem{$_}) { 815 my @f = sort keys %{ $Problem{$_} }; 816 my $f = join(" ", @f); 817 $f =~ s/(.{50,60}) /$1\n#\t/g; 818 print 819 "#\n", 820 "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n", 821 "#\t", $f, "\n#\n", 822 "# on your system may have errors because the locale test $_\n", 823 "# failed in ", (@f == 1 ? "that locale" : "those locales"), 824 ".\n"; 825 print <<EOW; 826# 827# If your users are not using these locales you are safe for the moment, 828# but please report this failure first to perlbug\@perl.com using the 829# perlbug script (as described in the INSTALL file) so that the exact 830# details of the failures can be sorted out first and then your operating 831# system supplier can be alerted about these anomalies. 832# 833EOW 834 $didwarn = 1; 835 } 836} 837 838# Tell which locales were okay and which were not. 839 840if ($didwarn) { 841 my (@s, @F); 842 843 foreach my $l (@Locale) { 844 my $p = 0; 845 foreach my $t (102..$last) { 846 $p++ if $Problem{$t}{$l}; 847 } 848 push @s, $l if $p == 0; 849 push @F, $l unless $p == 0; 850 } 851 852 if (@s) { 853 my $s = join(" ", @s); 854 $s =~ s/(.{50,60}) /$1\n#\t/g; 855 856 warn 857 "# The following locales\n#\n", 858 "#\t", $s, "\n#\n", 859 "# tested okay.\n#\n", 860 } else { 861 warn "# None of your locales were fully okay.\n"; 862 } 863 864 if (@F) { 865 my $F = join(" ", @F); 866 $F =~ s/(.{50,60}) /$1\n#\t/g; 867 868 warn 869 "# The following locales\n#\n", 870 "#\t", $F, "\n#\n", 871 "# had problems.\n#\n", 872 } else { 873 warn "# None of your locales were broken.\n"; 874 } 875 876 if (@utf8locale) { 877 my $S = join(" ", @utf8locale); 878 $S =~ s/(.{50,60}) /$1\n#\t/g; 879 880 warn "#\n# The following locales\n#\n", 881 "#\t", $S, "\n#\n", 882 "# were skipped for the tests ", 883 join(" ", sort {$a<=>$b} keys %utf8skip), "\n", 884 "# because UTF-8 and locales do not work together in Perl.\n#\n"; 885 } 886} 887 888sub last { 117 } 889 890# eof 891