diff options
Diffstat (limited to 'contrib/perl5/t/pragma/locale.t')
| -rwxr-xr-x | contrib/perl5/t/pragma/locale.t | 181 |
1 files changed, 127 insertions, 54 deletions
diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t index 414ceffe96ac..068fedeac818 100755 --- a/contrib/perl5/t/pragma/locale.t +++ b/contrib/perl5/t/pragma/locale.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; unshift @INC, '.'; require Config; import Config; if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { @@ -15,8 +15,18 @@ use strict; my $debug = 1; +use Dumpvalue; + +my $dumper = Dumpvalue->new( + tick => qq{"}, + quoteHighBit => 0, + unctrl => "quote" + ); sub debug { - print @_ if $debug; + return unless $debug; + my($mess) = join "", @_; + chop $mess; + print $dumper->stringify($mess,1), "\n"; } sub debugf { @@ -34,7 +44,9 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -print "1..", ($have_setlocale ? 116 : 98), "\n"; +my $last = $have_setlocale ? 116 : 98; + +print "1..$last\n"; use vars qw(&LC_ALL); @@ -242,13 +254,13 @@ Afrikaans:af:za:1 15 Arabic:ar:dz eg sa:6 arabic8 Brezhoneg Breton:br:fr:1 15 Bulgarski Bulgarian:bg:bg:5 -Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC +Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC Hrvatski Croatian:hr:hr:2 Cymraeg Welsh:cy:cy:1 14 15 Czech:cs:cz:2 Dansk Danish:dk:da:1 15 Nederlands Dutch:nl:be nl:1 15 -English American British:en:au ca gb ie nz us uk:1 15 cp850 +English American British:en:au ca gb ie nz us uk zw:1 15 cp850 Esperanto:eo:eo:3 Eesti Estonian:et:ee:4 6 13 Suomi Finnish:fi:fi:1 15 @@ -271,11 +283,12 @@ Latvian:lv:lv:4 6 13 Lithuanian:lt:lt:4 6 13 Macedonian:mk:mk:1 15 Maltese:mt:mt:3 -Norsk Norwegian:no:no:1 15 +Moldovan:mo:mo:2 +Norsk Norwegian:no no\@nynorsk:no:1 15 Occitan:oc:es:1 15 Polski Polish:pl:pl:2 Rumanian:ro:ro:2 -Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251 +Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866 Serbski Serbian:sr:yu:5 Slovak:sk:sk:2 Slovene Slovenian:sl:si:2 @@ -283,10 +296,11 @@ Sqhip Albanian:sq:sq:1 15 Svenska Swedish:sv:fi se:1 15 Thai:th:th:11 tis620 Turkish:tr:tr:9 turkish8 -Yiddish:::1 15 +Yiddish:yi::1 15 EOF if ($^O eq 'os390') { + # These cause heartburn. Broken locales? $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; $locales =~ s/Thai:th:th:11 tis620\n//; } @@ -326,6 +340,7 @@ sub decode_encodings { } } else { push @enc, $_; + push @enc, "$_.UTF-8"; } } if ($^O eq 'os390') { @@ -347,32 +362,61 @@ foreach (0..15) { trylocale("iso_latin_$_"); } -foreach my $locale (split(/\n/, $locales)) { - my ($locale_name, $language_codes, $country_codes, $encodings) = - split(/:/, $locale); - my @enc = decode_encodings($encodings); - foreach my $loc (split(/ /, $locale_name)) { - trylocale($loc); - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } - $loc = lc $loc; - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } +# Sanitize the environment so that we can run the external 'locale' +# program without the taint mode getting grumpy. + +# $ENV{PATH} is special in VMS. +delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv}; + +# Other subversive stuff. +delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; + +if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { + while (<LOCALES>) { + chomp; + trylocale($_); } - foreach my $lang (split(/ /, $language_codes)) { - trylocale($lang); - foreach my $country (split(/ /, $country_codes)) { - my $lc = "${lang}_${country}"; - trylocale($lc); + close(LOCALES); +} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { +# The SYS$I18N_LOCALE logical name search list was not present on +# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. + opendir(LOCALES, "SYS\$I18N_LOCALE:"); + while ($_ = readdir(LOCALES)) { + chomp; + trylocale($_); + } + close(LOCALES); +} else { + + # This is going to be slow. + + foreach my $locale (split(/\n/, $locales)) { + my ($locale_name, $language_codes, $country_codes, $encodings) = + split(/:/, $locale); + my @enc = decode_encodings($encodings); + foreach my $loc (split(/ /, $locale_name)) { + trylocale($loc); foreach my $enc (@enc) { - trylocale("$lc.$enc"); + trylocale("$loc.$enc"); } - my $lC = "${lang}_\U${country}"; - trylocale($lC); + $loc = lc $loc; foreach my $enc (@enc) { - trylocale("$lC.$enc"); + trylocale("$loc.$enc"); + } + } + foreach my $lang (split(/ /, $language_codes)) { + trylocale($lang); + foreach my $country (split(/ /, $country_codes)) { + my $lc = "${lang}_${country}"; + trylocale($lc); + foreach my $enc (@enc) { + trylocale("$lc.$enc"); + } + my $lC = "${lang}_\U${country}"; + trylocale($lC); + foreach my $enc (@enc) { + trylocale("$lC.$enc"); + } } } } @@ -380,6 +424,8 @@ foreach my $locale (split(/\n/, $locales)) { setlocale(LC_ALL, "C"); +sub utf8locale { $_[0] =~ /utf-?8/i } + @Locale = sort @Locale; debug "# Locales = @Locale\n"; @@ -392,8 +438,6 @@ my %Neoalpha; sub tryneoalpha { my ($Locale, $i, $test) = @_; - debug "# testing $i with locale '$Locale'\n" - unless $Testing{$i}{$Locale}++; unless ($test) { $Problem{$i}{$Locale} = 1; debug "# failed $i with locale '$Locale'\n"; @@ -405,7 +449,7 @@ sub tryneoalpha { foreach $Locale (@Locale) { debug "# Locale = $Locale\n"; @Alnum_ = getalnum_(); - debug "# \\w = @Alnum_\n"; + debug "# w = ", join("",@Alnum_), "\n"; unless (setlocale(LC_ALL, $Locale)) { foreach (99..103) { @@ -440,9 +484,9 @@ foreach $Locale (@Locale) { delete $lower{$_}; } - debug "# UPPER = ", join(" ", sort keys %UPPER ), "\n"; - debug "# lower = ", join(" ", sort keys %lower ), "\n"; - debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n"; + debug "# UPPER = ", join("", sort keys %UPPER ), "\n"; + debug "# lower = ", join("", sort keys %lower ), "\n"; + debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n"; # Find the alphabets that are not alphabets in the default locale. @@ -458,7 +502,7 @@ foreach $Locale (@Locale) { @Neoalpha = sort @Neoalpha; - debug "# Neoalpha = @Neoalpha\n"; + debug "# Neoalpha = ", join("",@Neoalpha), "\n"; if (@Neoalpha == 0) { # If we have no Neoalphas the remaining tests are no-ops. @@ -470,7 +514,10 @@ foreach $Locale (@Locale) { # Test \w. - { + if (utf8locale($Locale)) { + # Until the polymorphic regexen arrive. + debug "# skipping UTF-8 locale '$Locale'\n"; + } else { my $word = join('', @Neoalpha); $word =~ /^(\w+)$/; @@ -622,7 +669,9 @@ foreach $Locale (@Locale) { tryneoalpha($Locale, 114, $f == $c); } - debug "# testing 115 with locale '$Locale'\n"; + # Does taking lc separately differ from taking + # the lc "in-line"? (This was the bug 19990704.002, change #3568.) + # The bug was in the caching of the 'o'-magic. { use locale; @@ -645,8 +694,13 @@ foreach $Locale (@Locale) { lcA($x, $z) == 0 && lcB($x, $z) == 0); } - debug "# testing 116 with locale '$Locale'\n"; - { + # Does lc of an UPPER (if different from the UPPER) match + # case-insensitively the UPPER, and does the UPPER match + # case-insensitively the lc of the UPPER. And vice versa. + if (utf8locale($Locale)) { + # Until the polymorphic regexen arrive. + debug "# skipping UTF-8 locale '$Locale'\n"; + } else { use locale; my @f = (); @@ -661,14 +715,16 @@ foreach $Locale (@Locale) { push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; } tryneoalpha($Locale, 116, @f == 0); - print "# testing 116 failed for locale '$Locale' for characters @f\n" - if @f; + if (@f) { + print "# failed 116 locale '$Locale' characters @f\n" + } } + } # Recount the errors. -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { if ($_ == 102) { print "# The failure of test 102 is not necessarily fatal.\n"; @@ -684,7 +740,7 @@ foreach (99..116) { my $didwarn = 0; -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_}) { my @f = sort keys %{ $Problem{$_} }; my $f = join(" ", @f); @@ -709,26 +765,43 @@ EOW } } -# Tell which locales ere okay. +# Tell which locales were okay and which were not. if ($didwarn) { - my @s; + my (@s, @F); foreach my $l (@Locale) { my $p = 0; - foreach my $t (102..102) { + foreach my $t (102..$last) { $p++ if $Problem{$t}{$l}; } push @s, $l if $p == 0; + push @F, $l unless $p == 0; } - my $s = join(" ", @s); - $s =~ s/(.{50,60}) /$1\n#\t/g; + if (@s) { + my $s = join(" ", @s); + $s =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $s, "\n#\n", + "# tested okay.\n#\n", + } else { + warn "# None of your locales were fully okay.\n"; + } - warn - "# The following locales\n#\n", - "#\t", $s, "\n#\n", - "# tested okay.\n#\n", + if (@F) { + my $F = join(" ", @F); + $F =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $F, "\n#\n", + "# had problems.\n#\n", + } else { + warn "# None of your locales were broken.\n"; + } } # eof |