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