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	# 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
438setlocale(LC_ALL, "C");
439
440if ($^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
451debug "# Locales =\n";
452for ( @Locale ) {
453    debug "# $_\n";
454}
455
456my %Problem;
457my %Okay;
458my %Testing;
459my @Neoalpha;
460my %Neoalpha;
461
462sub 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
472foreach $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
810foreach (&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
824my $didwarn = 0;
825
826foreach (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#
846EOW
847	$didwarn = 1;
848    }
849}
850
851# Tell which locales were okay and which were not.
852
853if ($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    }
899}
900
901sub last { 117 }
902
903# eof
904