This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
lib/locale.t: Make Windows machines failures TODOs
[perl5.git] / lib / locale.t
1 #!./perl -wT
2
3 # This tests plain 'use locale' and adorned 'use locale ":not_characters"'
4 # Because these pragmas are compile time, and I (khw) am trying to test
5 # without using 'eval' as much as possible, which might cloud the issue,  the
6 # crucial parts of the code are duplicated in a block for each pragma.
7
8 # To make a TODO test, add the string 'TODO' to its %test_names value
9
10 binmode STDOUT, ':utf8';
11 binmode STDERR, ':utf8';
12
13 BEGIN {
14     chdir 't' if -d 't';
15     @INC = '../lib';
16     unshift @INC, '.';
17     require Config; import Config;
18     if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
19         print "1..0\n";
20         exit;
21     }
22     $| = 1;
23 }
24
25 use strict;
26 use feature 'fc';
27
28 my $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
29
30 # Certain tests have been shown to be problematical for a few locales.  Don't
31 # fail them unless at least this percentage of the tested locales fail.
32 # Some Windows machines are defective in every in every locale but the C,
33 # calling \t printable; superscripts to be digits, etc.  See
34 # http://markmail.org/message/5jwam4xsx4amsdnv
35 # (There aren't 1000 locales currently in existence, so 99.9 works)
36 my $acceptable_fold_failure_percentage = $^O eq 'MSWin32' ? 99.9 : 5;
37
38 use Dumpvalue;
39
40 my $dumper = Dumpvalue->new(
41                             tick => qq{"},
42                             quoteHighBit => 0,
43                             unctrl => "quote"
44                            );
45 sub debug {
46   return unless $debug;
47   my($mess) = join "", @_;
48   chop $mess;
49   print $dumper->stringify($mess,1), "\n";
50 }
51
52 sub debugf {
53     printf @_ if $debug;
54 }
55
56 my $have_setlocale = 0;
57 eval {
58     require POSIX;
59     import POSIX ':locale_h';
60     $have_setlocale++;
61 };
62
63 # Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
64 # and mingw32 uses said silly CRT
65 # This doesn't seem to be an issue any more, at least on Windows XP,
66 # so re-enable the tests for Windows XP onwards.
67 my $winxp = ($^O eq 'MSWin32' && defined &Win32::GetOSVersion &&
68                 join('.', (Win32::GetOSVersion())[1..2]) >= 5.1);
69 $have_setlocale = 0 if ((($^O eq 'MSWin32' && !$winxp) || $^O eq 'NetWare') &&
70                 $Config{cc} =~ /^(cl|gcc)/i);
71
72 # UWIN seems to loop after taint tests, just skip for now
73 $have_setlocale = 0 if ($^O =~ /^uwin/);
74
75 $a = 'abc %';
76
77 my $test_num = 0;
78
79 sub ok {
80     my ($result, $message) = @_;
81     $message = "" unless defined $message;
82
83     print 'not ' unless ($result);
84     print "ok " . ++$test_num;
85     print " $message";
86     print "\n";
87 }
88
89 # First we'll do a lot of taint checking for locales.
90 # This is the easiest to test, actually, as any locale,
91 # even the default locale will taint under 'use locale'.
92
93 sub is_tainted { # hello, camel two.
94     no warnings 'uninitialized' ;
95     my $dummy;
96     local $@;
97     not eval { $dummy = join("", @_), kill 0; 1 }
98 }
99
100 sub check_taint ($;$) {
101     my $message_tail = $_[1] // "";
102     $message_tail = ": $message_tail" if $message_tail;
103     ok is_tainted($_[0]), "verify that is tainted$message_tail";
104 }
105
106 sub check_taint_not ($;$) {
107     my $message_tail = $_[1] // "";
108     $message_tail = ": $message_tail" if $message_tail;
109     ok((not is_tainted($_[0])), "verify that isn't tainted$message_tail");
110 }
111
112 "\tb\t" =~ /^m?(\s)(.*)\1$/;
113 check_taint_not   $&, "not tainted outside 'use locale'";
114 ;
115
116 use locale;     # engage locale and therefore locale taint.
117
118 check_taint_not   $a;
119
120 check_taint       uc($a);
121 check_taint       "\U$a";
122 check_taint       ucfirst($a);
123 check_taint       "\u$a";
124 check_taint       lc($a);
125 check_taint       fc($a);
126 check_taint       "\L$a";
127 check_taint       "\F$a";
128 check_taint       lcfirst($a);
129 check_taint       "\l$a";
130
131 check_taint_not  sprintf('%e', 123.456);
132 check_taint_not  sprintf('%f', 123.456);
133 check_taint_not  sprintf('%g', 123.456);
134 check_taint_not  sprintf('%d', 123.456);
135 check_taint_not  sprintf('%x', 123.456);
136
137 $_ = $a;        # untaint $_
138
139 $_ = uc($a);    # taint $_
140
141 check_taint      $_;
142
143 /(\w)/; # taint $&, $`, $', $+, $1.
144 check_taint      $&;
145 check_taint      $`;
146 check_taint      $';
147 check_taint      $+;
148 check_taint      $1;
149 check_taint_not  $2;
150
151 /(.)/;  # untaint $&, $`, $', $+, $1.
152 check_taint_not  $&;
153 check_taint_not  $`;
154 check_taint_not  $';
155 check_taint_not  $+;
156 check_taint_not  $1;
157 check_taint_not  $2;
158
159 /(\W)/; # taint $&, $`, $', $+, $1.
160 check_taint      $&;
161 check_taint      $`;
162 check_taint      $';
163 check_taint      $+;
164 check_taint      $1;
165 check_taint_not  $2;
166
167 /(\s)/; # taint $&, $`, $', $+, $1.
168 check_taint      $&;
169 check_taint      $`;
170 check_taint      $';
171 check_taint      $+;
172 check_taint      $1;
173 check_taint_not  $2;
174
175 /(\S)/; # taint $&, $`, $', $+, $1.
176 check_taint      $&;
177 check_taint      $`;
178 check_taint      $';
179 check_taint      $+;
180 check_taint      $1;
181 check_taint_not  $2;
182
183 $_ = $a;        # untaint $_
184
185 check_taint_not  $_;
186
187 /(b)/;          # this must not taint
188 check_taint_not  $&;
189 check_taint_not  $`;
190 check_taint_not  $';
191 check_taint_not  $+;
192 check_taint_not  $1;
193 check_taint_not  $2;
194
195 $_ = $a;        # untaint $_
196
197 check_taint_not  $_;
198
199 $b = uc($a);    # taint $b
200 s/(.+)/$b/;     # this must taint only the $_
201
202 check_taint      $_;
203 check_taint_not  $&;
204 check_taint_not  $`;
205 check_taint_not  $';
206 check_taint_not  $+;
207 check_taint_not  $1;
208 check_taint_not  $2;
209
210 $_ = $a;        # untaint $_
211
212 s/(.+)/b/;      # this must not taint
213 check_taint_not  $_;
214 check_taint_not  $&;
215 check_taint_not  $`;
216 check_taint_not  $';
217 check_taint_not  $+;
218 check_taint_not  $1;
219 check_taint_not  $2;
220
221 $b = $a;        # untaint $b
222
223 ($b = $a) =~ s/\w/$&/;
224 check_taint      $b;    # $b should be tainted.
225 check_taint_not  $a;    # $a should be not.
226
227 $_ = $a;        # untaint $_
228
229 s/(\w)/\l$1/;   # this must taint
230 check_taint      $_;
231 check_taint      $&;
232 check_taint      $`;
233 check_taint      $';
234 check_taint      $+;
235 check_taint      $1;
236 check_taint_not  $2;
237
238 $_ = $a;        # untaint $_
239
240 s/(\w)/\L$1/;   # this must taint
241 check_taint      $_;
242 check_taint      $&;
243 check_taint      $`;
244 check_taint      $';
245 check_taint      $+;
246 check_taint      $1;
247 check_taint_not  $2;
248
249 $_ = $a;        # untaint $_
250
251 s/(\w)/\u$1/;   # this must taint
252 check_taint      $_;
253 check_taint      $&;
254 check_taint      $`;
255 check_taint      $';
256 check_taint      $+;
257 check_taint      $1;
258 check_taint_not  $2;
259
260 $_ = $a;        # untaint $_
261
262 s/(\w)/\U$1/;   # this must taint
263 check_taint      $_;
264 check_taint      $&;
265 check_taint      $`;
266 check_taint      $';
267 check_taint      $+;
268 check_taint      $1;
269 check_taint_not  $2;
270
271 # After all this tainting $a should be cool.
272
273 check_taint_not  $a;
274
275 {   # This is just the previous tests copied here with a different
276     # compile-time pragma.
277
278     use locale ':not_characters'; # engage restricted locale with different
279                                   # tainting rules
280
281     check_taint_not   $a;
282
283     check_taint_not     uc($a);
284     check_taint_not     "\U$a";
285     check_taint_not     ucfirst($a);
286     check_taint_not     "\u$a";
287     check_taint_not     lc($a);
288     check_taint_not     fc($a);
289     check_taint_not     "\L$a";
290     check_taint_not     "\F$a";
291     check_taint_not     lcfirst($a);
292     check_taint_not     "\l$a";
293
294     check_taint_not  sprintf('%e', 123.456);
295     check_taint_not  sprintf('%f', 123.456);
296     check_taint_not  sprintf('%g', 123.456);
297     check_taint_not  sprintf('%d', 123.456);
298     check_taint_not  sprintf('%x', 123.456);
299
300     $_ = $a;    # untaint $_
301
302     $_ = uc($a);        # taint $_
303
304     check_taint_not     $_;
305
306     /(\w)/;     # taint $&, $`, $', $+, $1.
307     check_taint_not     $&;
308     check_taint_not     $`;
309     check_taint_not     $';
310     check_taint_not     $+;
311     check_taint_not     $1;
312     check_taint_not  $2;
313
314     /(.)/;      # untaint $&, $`, $', $+, $1.
315     check_taint_not  $&;
316     check_taint_not  $`;
317     check_taint_not  $';
318     check_taint_not  $+;
319     check_taint_not  $1;
320     check_taint_not  $2;
321
322     /(\W)/;     # taint $&, $`, $', $+, $1.
323     check_taint_not     $&;
324     check_taint_not     $`;
325     check_taint_not     $';
326     check_taint_not     $+;
327     check_taint_not     $1;
328     check_taint_not  $2;
329
330     /(\s)/;     # taint $&, $`, $', $+, $1.
331     check_taint_not     $&;
332     check_taint_not     $`;
333     check_taint_not     $';
334     check_taint_not     $+;
335     check_taint_not     $1;
336     check_taint_not  $2;
337
338     /(\S)/;     # taint $&, $`, $', $+, $1.
339     check_taint_not     $&;
340     check_taint_not     $`;
341     check_taint_not     $';
342     check_taint_not     $+;
343     check_taint_not     $1;
344     check_taint_not  $2;
345
346     $_ = $a;    # untaint $_
347
348     check_taint_not  $_;
349
350     /(b)/;              # this must not taint
351     check_taint_not  $&;
352     check_taint_not  $`;
353     check_taint_not  $';
354     check_taint_not  $+;
355     check_taint_not  $1;
356     check_taint_not  $2;
357
358     $_ = $a;    # untaint $_
359
360     check_taint_not  $_;
361
362     $b = uc($a);        # taint $b
363     s/(.+)/$b/; # this must taint only the $_
364
365     check_taint_not     $_;
366     check_taint_not  $&;
367     check_taint_not  $`;
368     check_taint_not  $';
369     check_taint_not  $+;
370     check_taint_not  $1;
371     check_taint_not  $2;
372
373     $_ = $a;    # untaint $_
374
375     s/(.+)/b/;  # this must not taint
376     check_taint_not  $_;
377     check_taint_not  $&;
378     check_taint_not  $`;
379     check_taint_not  $';
380     check_taint_not  $+;
381     check_taint_not  $1;
382     check_taint_not  $2;
383
384     $b = $a;    # untaint $b
385
386     ($b = $a) =~ s/\w/$&/;
387     check_taint_not     $b;     # $b should be tainted.
388     check_taint_not  $a;        # $a should be not.
389
390     $_ = $a;    # untaint $_
391
392     s/(\w)/\l$1/;       # this must taint
393     check_taint_not     $_;
394     check_taint_not     $&;
395     check_taint_not     $`;
396     check_taint_not     $';
397     check_taint_not     $+;
398     check_taint_not     $1;
399     check_taint_not  $2;
400
401     $_ = $a;    # untaint $_
402
403     s/(\w)/\L$1/;       # this must taint
404     check_taint_not     $_;
405     check_taint_not     $&;
406     check_taint_not     $`;
407     check_taint_not     $';
408     check_taint_not     $+;
409     check_taint_not     $1;
410     check_taint_not  $2;
411
412     $_ = $a;    # untaint $_
413
414     s/(\w)/\u$1/;       # this must taint
415     check_taint_not     $_;
416     check_taint_not     $&;
417     check_taint_not     $`;
418     check_taint_not     $';
419     check_taint_not     $+;
420     check_taint_not     $1;
421     check_taint_not  $2;
422
423     $_ = $a;    # untaint $_
424
425     s/(\w)/\U$1/;       # this must taint
426     check_taint_not     $_;
427     check_taint_not     $&;
428     check_taint_not     $`;
429     check_taint_not     $';
430     check_taint_not     $+;
431     check_taint_not     $1;
432     check_taint_not  $2;
433
434     # After all this tainting $a should be cool.
435
436     check_taint_not  $a;
437 }
438
439 # Here are in scope of 'use locale'
440
441 # I think we've seen quite enough of taint.
442 # Let us do some *real* locale work now,
443 # unless setlocale() is missing (i.e. minitest).
444
445 unless ($have_setlocale) {
446     print "1..$test_num\n";
447     exit;
448 }
449
450 # The test number before our first setlocale()
451 my $final_without_setlocale = $test_num;
452
453 # Find locales.
454
455 debug "# Scanning for locales...\n";
456
457 # Note that it's okay that some languages have their native names
458 # capitalized here even though that's not "right".  They are lowercased
459 # anyway later during the scanning process (and besides, some clueless
460 # vendor might have them capitalized erroneously anyway).
461
462 my $locales = <<EOF;
463 Afrikaans:af:za:1 15
464 Arabic:ar:dz eg sa:6 arabic8
465 Brezhoneg Breton:br:fr:1 15
466 Bulgarski Bulgarian:bg:bg:5
467 Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
468 Hrvatski Croatian:hr:hr:2
469 Cymraeg Welsh:cy:cy:1 14 15
470 Czech:cs:cz:2
471 Dansk Danish:da:dk:1 15
472 Nederlands Dutch:nl:be nl:1 15
473 English American British:en:au ca gb ie nz us uk zw:1 15 cp850
474 Esperanto:eo:eo:3
475 Eesti Estonian:et:ee:4 6 13
476 Suomi Finnish:fi:fi:1 15
477 Flamish::fl:1 15
478 Deutsch German:de:at be ch de lu:1 15
479 Euskaraz Basque:eu:es fr:1 15
480 Galego Galician:gl:es:1 15
481 Ellada Greek:el:gr:7 g8
482 Frysk:fy:nl:1 15
483 Greenlandic:kl:gl:4 6
484 Hebrew:iw:il:8 hebrew8
485 Hungarian:hu:hu:2
486 Indonesian:id:id:1 15
487 Gaeilge Irish:ga:IE:1 14 15
488 Italiano Italian:it:ch it:1 15
489 Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis
490 Korean:ko:kr:
491 Latine Latin:la:va:1 15
492 Latvian:lv:lv:4 6 13
493 Lithuanian:lt:lt:4 6 13
494 Macedonian:mk:mk:1 15
495 Maltese:mt:mt:3
496 Moldovan:mo:mo:2
497 Norsk Norwegian:no no\@nynorsk nb nn:no:1 15
498 Occitan:oc:es:1 15
499 Polski Polish:pl:pl:2
500 Rumanian:ro:ro:2
501 Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
502 Serbski Serbian:sr:yu:5
503 Slovak:sk:sk:2
504 Slovene Slovenian:sl:si:2
505 Sqhip Albanian:sq:sq:1 15
506 Svenska Swedish:sv:fi se:1 15
507 Thai:th:th:11 tis620
508 Turkish:tr:tr:9 turkish8
509 Yiddish:yi::1 15
510 EOF
511
512 if ($^O eq 'os390') {
513     # These cause heartburn.  Broken locales?
514     $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
515     $locales =~ s/Thai:th:th:11 tis620\n//;
516 }
517
518 sub in_utf8 () { $^H & 0x08 || (${^OPEN} || "") =~ /:utf8/ }
519
520 if (in_utf8) {
521     require "lib/locale/utf8";
522 } else {
523     require "lib/locale/latin1";
524 }
525
526 my @Locale;
527 my $Locale;
528 my @Word_;
529 my @Digit_;
530 my @Space_;
531 my @Alpha_;
532 my @Alnum_;
533 my @Ascii_;
534 my @Blank_;
535 my @Cntrl_;
536 my @Graph_;
537 my @Lower_;
538 my @Print_;
539 my @Upper_;
540 my @Xdigit_;
541 my @Cased_;
542
543 sub trylocale {
544     my $locale = shift;
545     return if grep { $locale eq $_ } @Locale;
546     return unless setlocale(&POSIX::LC_ALL, $locale);
547     my $badutf8;
548     {
549         local $SIG{__WARN__} = sub {
550             $badutf8 = $_[0] =~ /Malformed UTF-8/;
551         };
552         $Locale =~ /UTF-?8/i;
553     }
554
555     if ($badutf8) {
556         ok(0, "Locale name contains malformed utf8");
557         return;
558     }
559     push @Locale, $locale;
560 }
561
562 sub decode_encodings {
563     my @enc;
564
565     foreach (split(/ /, shift)) {
566         if (/^(\d+)$/) {
567             push @enc, "ISO8859-$1";
568             push @enc, "iso8859$1";     # HP
569             if ($1 eq '1') {
570                  push @enc, "roman8";   # HP
571             }
572         } else {
573             push @enc, $_;
574             push @enc, "$_.UTF-8";
575         }
576     }
577     if ($^O eq 'os390') {
578         push @enc, qw(IBM-037 IBM-819 IBM-1047);
579     }
580
581     return @enc;
582 }
583
584 trylocale("C");
585 trylocale("POSIX");
586 foreach (0..15) {
587     trylocale("ISO8859-$_");
588     trylocale("iso8859$_");
589     trylocale("iso8859-$_");
590     trylocale("iso_8859_$_");
591     trylocale("isolatin$_");
592     trylocale("isolatin-$_");
593     trylocale("iso_latin_$_");
594 }
595
596 # Sanitize the environment so that we can run the external 'locale'
597 # program without the taint mode getting grumpy.
598
599 # $ENV{PATH} is special in VMS.
600 delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
601
602 # Other subversive stuff.
603 delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
604
605 if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
606     while (<LOCALES>) {
607         # It seems that /usr/bin/locale steadfastly outputs 8 bit data, which
608         # ain't great when we're running this testPERL_UNICODE= so that utf8
609         # locales will cause all IO hadles to default to (assume) utf8
610         next unless utf8::valid($_);
611         chomp;
612         trylocale($_);
613     }
614     close(LOCALES);
615 } elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
616 # The SYS$I18N_LOCALE logical name search list was not present on
617 # VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
618     opendir(LOCALES, "SYS\$I18N_LOCALE:");
619     while ($_ = readdir(LOCALES)) {
620         chomp;
621         trylocale($_);
622     }
623     close(LOCALES);
624 } elsif ($^O eq 'openbsd' && -e '/usr/share/locale') {
625
626    # OpenBSD doesn't have a locale executable, so reading /usr/share/locale
627    # is much easier and faster than the last resort method.
628
629     opendir(LOCALES, '/usr/share/locale');
630     while ($_ = readdir(LOCALES)) {
631         chomp;
632         trylocale($_);
633     }
634     close(LOCALES);
635 } else {
636
637     # This is going to be slow.
638
639     foreach my $locale (split(/\n/, $locales)) {
640         my ($locale_name, $language_codes, $country_codes, $encodings) =
641             split(/:/, $locale);
642         my @enc = decode_encodings($encodings);
643         foreach my $loc (split(/ /, $locale_name)) {
644             trylocale($loc);
645             foreach my $enc (@enc) {
646                 trylocale("$loc.$enc");
647             }
648             $loc = lc $loc;
649             foreach my $enc (@enc) {
650                 trylocale("$loc.$enc");
651             }
652         }
653         foreach my $lang (split(/ /, $language_codes)) {
654             trylocale($lang);
655             foreach my $country (split(/ /, $country_codes)) {
656                 my $lc = "${lang}_${country}";
657                 trylocale($lc);
658                 foreach my $enc (@enc) {
659                     trylocale("$lc.$enc");
660                 }
661                 my $lC = "${lang}_\U${country}";
662                 trylocale($lC);
663                 foreach my $enc (@enc) {
664                     trylocale("$lC.$enc");
665                 }
666             }
667         }
668     }
669 }
670
671 setlocale(&POSIX::LC_ALL, "C");
672
673 if ($^O eq 'darwin') {
674     # Darwin 8/Mac OS X 10.4 and 10.5 have bad Basque locales: perl bug #35895,
675     # Apple bug ID# 4139653. It also has a problem in Byelorussian.
676     (my $v) = $Config{osvers} =~ /^(\d+)/;
677     if ($v >= 8 and $v < 10) {
678         debug "# Skipping eu_ES, be_BY locales -- buggy in Darwin\n";
679         @Locale = grep ! m/^(eu_ES(?:\..*)?|be_BY\.CP1131)$/, @Locale;
680     } elsif ($v < 12) {
681         debug "# Skipping be_BY locales -- buggy in Darwin\n";
682         @Locale = grep ! m/^be_BY\.CP1131$/, @Locale;
683     }
684 }
685
686 @Locale = sort @Locale;
687
688 debug "# Locales =\n";
689 for ( @Locale ) {
690     debug "# $_\n";
691 }
692
693 my %Problem;
694 my %Okay;
695 my %Testing;
696 my @Added_alpha;   # Alphas that aren't in the C locale.
697 my %test_names;
698
699 sub display_characters {
700     # This returns a display string denoting the input parameter @_, each
701     # entry of which is a single character in the range 0-255.  The first part
702     # of the output is a string of the characters in @_ that are ASCII
703     # graphics, and hence unambiguously displayable.  They are given by code
704     # point order.  The second part is the remaining code points, the ordinals
705     # of which are each displayed as 2-digit hex.  Blanks are inserted so as
706     # to keep anything from the first part looking like a 2-digit hex number.
707
708     no locale;
709     my @chars = sort { ord $a <=> ord $b } @_;
710     my $output = "";
711     my $hex = "";
712     my $range_start;
713     my $start_class;
714     push @chars, chr(258);  # This sentinel simplifies the loop termination
715                             # logic
716     foreach my $i (0 .. @chars - 1) {
717         my $char = $chars[$i];
718         my $range_end;
719         my $class;
720
721         # We avoid using [:posix:] classes, as these are being tested in this
722         # file.  Each equivalence class below is for things that can appear in
723         # a range; those that can't be in a range have class -1.  0 for those
724         # which should be output in hex; and >0 for the other ranges
725         if ($char =~ /[A-Z]/) {
726             $class = 2;
727         }
728         elsif ($char =~ /[a-z]/) {
729             $class = 3;
730         }
731         elsif ($char =~ /[0-9]/) {
732             $class = 4;
733         }
734         elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
735             $class = -1;    # Punct never appears in a range
736         }
737         else {
738             $class = 0;     # Output in hex
739         }
740
741         if (! defined $range_start) {
742             if ($class < 0) {
743                 $output .= $char;
744             }
745             else {
746                 $range_start = ord $char;
747                 $start_class = $class;
748             }
749         } # A range ends if not consecutive, or the class-type changes
750         elsif (ord $char != ($range_end = ord($chars[$i-1])) + 1
751               || $class != $start_class)
752         {
753
754             # Here, the current character is not in the range.  This means the
755             # previous character must have been.  Output the range up through
756             # that one.
757             my $range_length = $range_end - $range_start + 1;
758             if ($start_class > 0) {
759                 $output .= " " . chr($range_start);
760                 $output .= "-" . chr($range_end) if $range_length > 1;
761             }
762             else {
763                 $hex .= sprintf(" %02X", $range_start);
764                 $hex .= sprintf("-%02X", $range_end) if $range_length > 1;
765             }
766
767             # Handle the new current character, as potentially beginning a new
768             # range
769             undef $range_start;
770             redo;
771         }
772     }
773
774     $output =~ s/^ //;
775     $hex =~ s/^ // if ! length $output;
776     return "$output$hex";
777 }
778
779 sub report_result {
780     my ($Locale, $i, $pass_fail, $message) = @_;
781     $message //= "";
782     $message = "  ($message)" if $message;
783     unless ($pass_fail) {
784         $Problem{$i}{$Locale} = 1;
785         debug "# failed $i ($test_names{$i}) with locale '$Locale'$message\n";
786     } else {
787         push @{$Okay{$i}}, $Locale;
788     }
789 }
790
791 sub report_multi_result {
792     my ($Locale, $i, $results_ref) = @_;
793
794     # $results_ref points to an array, each element of which is a character that was
795     # in error for this test numbered '$i'.  If empty, the test passed
796
797     my $message = "";
798     if (@$results_ref) {
799         $message = join " ", "for", display_characters(@$results_ref);
800     }
801     report_result($Locale, $i, @$results_ref == 0, $message);
802 }
803
804 my $first_locales_test_number = $final_without_setlocale + 1;
805 my $locales_test_number;
806 my $not_necessarily_a_problem_test_number;
807 my $first_casing_test_number;
808 my $final_casing_test_number;
809 my %setlocale_failed;   # List of locales that setlocale() didn't work on
810
811 foreach $Locale (@Locale) {
812     $locales_test_number = $first_locales_test_number - 1;
813     debug "# Locale = $Locale\n";
814
815     unless (setlocale(&POSIX::LC_ALL, $Locale)) {
816         $setlocale_failed{$Locale} = $Locale;
817         next;
818     }
819
820     # We test UTF-8 locales only under ':not_characters'; otherwise they have
821     # documented deficiencies.  Non- UTF-8 locales are tested only under plain
822     # 'use locale', as otherwise we would have to convert everything in them
823     # to Unicode.
824     # The locale name doesn't necessarily have to have "utf8" in it to be a
825     # UTF-8 locale, but it works mostly.
826     my $is_utf8_locale = $Locale =~ /UTF-?8/i;
827
828     my %UPPER = ();     # All alpha X for which uc(X) == X and lc(X) != X
829     my %lower = ();     # All alpha X for which lc(X) == X and uc(X) != X
830     my %BoThCaSe = ();  # All alpha X for which uc(X) == lc(X) == X
831
832     if (! $is_utf8_locale) {
833         use locale;
834         @Word_ = grep /\w/, map { chr } 0..255;
835         @Digit_ = grep /\d/, map { chr } 0..255;
836         @Space_ = grep /\s/, map { chr } 0..255;
837         @Alpha_ = grep /[[:alpha:]]/, map {chr } 0..255;
838         @Alnum_ = grep /[[:alnum:]]/, map {chr } 0..255;
839         @Ascii_ = grep /[[:ascii:]]/, map {chr } 0..255;
840         @Blank_ = grep /[[:blank:]]/, map {chr } 0..255;
841         @Cntrl_ = grep /[[:cntrl:]]/, map {chr } 0..255;
842         @Graph_ = grep /[[:graph:]]/, map {chr } 0..255;
843         @Lower_ = grep /[[:lower:]]/, map {chr } 0..255;
844         @Print_ = grep /[[:print:]]/, map {chr } 0..255;
845         @Upper_ = grep /[[:upper:]]/, map {chr } 0..255;
846         @Xdigit_ = grep /[[:xdigit:]]/, map {chr } 0..255;
847         @Cased_ = grep /[[:upper:]]/i, map {chr } 0..255;
848
849         # Sieve the uppercase and the lowercase.
850
851         for (@Word_) {
852             if (/[^\d_]/) { # skip digits and the _
853                 if (uc($_) eq $_) {
854                     $UPPER{$_} = $_;
855                 }
856                 if (lc($_) eq $_) {
857                     $lower{$_} = $_;
858                 }
859             }
860         }
861     }
862     else {
863         use locale ':not_characters';
864         @Word_ = grep /\w/, map { chr } 0..255;
865         @Digit_ = grep /\d/, map { chr } 0..255;
866         @Space_ = grep /\s/, map { chr } 0..255;
867         @Alpha_ = grep /[[:alpha:]]/, map {chr } 0..255;
868         @Alnum_ = grep /[[:alnum:]]/, map {chr } 0..255;
869         @Ascii_ = grep /[[:ascii:]]/, map {chr } 0..255;
870         @Blank_ = grep /[[:blank:]]/, map {chr } 0..255;
871         @Cntrl_ = grep /[[:cntrl:]]/, map {chr } 0..255;
872         @Graph_ = grep /[[:graph:]]/, map {chr } 0..255;
873         @Lower_ = grep /[[:lower:]]/, map {chr } 0..255;
874         @Print_ = grep /[[:print:]]/, map {chr } 0..255;
875         @Upper_ = grep /[[:upper:]]/, map {chr } 0..255;
876         @Xdigit_ = grep /[[:xdigit:]]/, map {chr } 0..255;
877         @Cased_ = grep /[[:upper:]]/i, map {chr } 0..255;
878         for (@Word_) {
879             if (/[^\d_]/) { # skip digits and the _
880                 if (uc($_) eq $_) {
881                     $UPPER{$_} = $_;
882                 }
883                 if (lc($_) eq $_) {
884                     $lower{$_} = $_;
885                 }
886             }
887         }
888     }
889
890     debug "# :upper:  = ", display_characters(@Upper_), "\n";
891     debug "# :lower:  = ", display_characters(@Lower_), "\n";
892     debug "# :cased:  = ", display_characters(@Cased_), "\n";
893     debug "# :alpha:  = ", display_characters(@Alpha_), "\n";
894     debug "# :alnum:  = ", display_characters(@Alnum_), "\n";
895     debug "#  w       = ", display_characters(@Word_), "\n";
896     debug "# :graph:  = ", display_characters(@Graph_), "\n";
897     debug "# :print:  = ", display_characters(@Print_), "\n";
898     debug "#  d       = ", display_characters(@Digit_), "\n";
899     debug "# :xdigit: = ", display_characters(@Xdigit_), "\n";
900     debug "# :blank:  = ", display_characters(@Blank_), "\n";
901     debug "#  s       = ", display_characters(@Space_), "\n";
902     debug "# :cntrl:  = ", display_characters(@Cntrl_), "\n";
903     debug "# :ascii:  = ", display_characters(@Ascii_), "\n";
904
905     foreach (keys %UPPER) {
906
907         $BoThCaSe{$_}++ if exists $lower{$_};
908     }
909     foreach (keys %lower) {
910         $BoThCaSe{$_}++ if exists $UPPER{$_};
911     }
912     foreach (keys %BoThCaSe) {
913         delete $UPPER{$_};
914         delete $lower{$_};
915     }
916
917     debug "# UPPER    = ", display_characters(keys %UPPER), "\n";
918     debug "# lower    = ", display_characters(keys %lower), "\n";
919     debug "# BoThCaSe = ", display_characters(keys %BoThCaSe), "\n";
920
921     my @failures;
922     my @fold_failures;
923     foreach my $x (sort keys %UPPER) {
924         my $ok;
925         my $fold_ok;
926         if ($is_utf8_locale) {
927             use locale ':not_characters';
928             $ok = $x =~ /[[:upper:]]/;
929             $fold_ok = $x =~ /[[:lower:]]/i;
930         }
931         else {
932             use locale;
933             $ok = $x =~ /[[:upper:]]/;
934             $fold_ok = $x =~ /[[:lower:]]/i;
935         }
936         push @failures, $x unless $ok;
937         push @fold_failures, $x unless $fold_ok;
938     }
939     $locales_test_number++;
940     $first_casing_test_number = $locales_test_number;
941     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
942     report_multi_result($Locale, $locales_test_number, \@failures);
943
944     $locales_test_number++;
945
946     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
947     report_multi_result($Locale, $locales_test_number, \@fold_failures);
948
949     undef @failures;
950     undef @fold_failures;
951
952     foreach my $x (sort keys %lower) {
953         my $ok;
954         my $fold_ok;
955         if ($is_utf8_locale) {
956             use locale ':not_characters';
957             $ok = $x =~ /[[:lower:]]/;
958             $fold_ok = $x =~ /[[:upper:]]/i;
959         }
960         else {
961             use locale;
962             $ok = $x =~ /[[:lower:]]/;
963             $fold_ok = $x =~ /[[:upper:]]/i;
964         }
965         push @failures, $x unless $ok;
966         push @fold_failures, $x unless $fold_ok;
967     }
968
969     $locales_test_number++;
970     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
971     report_multi_result($Locale, $locales_test_number, \@failures);
972
973     $locales_test_number++;
974     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
975     report_multi_result($Locale, $locales_test_number, \@fold_failures);
976
977     {   # Find the alphabetic characters that are not considered alphabetics
978         # in the default (C) locale.
979
980         no locale;
981
982         @Added_alpha = ();
983         for (keys %UPPER, keys %lower, keys %BoThCaSe) {
984             push(@Added_alpha, $_) if (/\W/);
985         }
986     }
987
988     @Added_alpha = sort @Added_alpha;
989
990     debug "# Added_alpha = ", display_characters(@Added_alpha), "\n";
991
992     # Cross-check the whole 8-bit character set.
993
994     ++$locales_test_number;
995     my @f;
996     $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
997     for (map { chr } 0..255) {
998         if ($is_utf8_locale) {
999             use locale ':not_characters';
1000             push @f, $_ unless /[[:word:]]/ == /\w/;
1001         }
1002         else {
1003             push @f, $_ unless /[[:word:]]/ == /\w/;
1004         }
1005     }
1006     report_multi_result($Locale, $locales_test_number, \@f);
1007
1008     ++$locales_test_number;
1009     undef @f;
1010     $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1011     for (map { chr } 0..255) {
1012         if ($is_utf8_locale) {
1013             use locale ':not_characters';
1014             push @f, $_ unless /[[:digit:]]/ == /\d/;
1015         }
1016         else {
1017             push @f, $_ unless /[[:digit:]]/ == /\d/;
1018         }
1019     }
1020     report_multi_result($Locale, $locales_test_number, \@f);
1021
1022     ++$locales_test_number;
1023     undef @f;
1024     $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1025     for (map { chr } 0..255) {
1026         if ($is_utf8_locale) {
1027             use locale ':not_characters';
1028             push @f, $_ unless /[[:space:]]/ == /\s/;
1029         }
1030         else {
1031             push @f, $_ unless /[[:space:]]/ == /\s/;
1032         }
1033     }
1034     report_multi_result($Locale, $locales_test_number, \@f);
1035
1036     ++$locales_test_number;
1037     undef @f;
1038     $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1039     for (map { chr } 0..255) {
1040         if ($is_utf8_locale) {
1041             use locale ':not_characters';
1042             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1043                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1044                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1045                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1046                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1047                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1048                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1049                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1050                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1051                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1052                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1053                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1054                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1055
1056                     # effectively is what [:cased:] would be if it existed.
1057                     (/[[:upper:]]/i xor /[[:^upper:]]/i);
1058         }
1059         else {
1060             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1061                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1062                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1063                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1064                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1065                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1066                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1067                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1068                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1069                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1070                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1071                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1072                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1073                     (/[[:upper:]]/i xor /[[:^upper:]]/i);
1074         }
1075     }
1076     report_multi_result($Locale, $locales_test_number, \@f);
1077
1078     # The rules for the relationships are given in:
1079     # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1080
1081     ++$locales_test_number;
1082     undef @f;
1083     $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1084     for (map { chr } 0..255) {
1085         if ($is_utf8_locale) {
1086             use locale ':not_characters';
1087             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1088         }
1089         else {
1090             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1091         }
1092     }
1093     report_multi_result($Locale, $locales_test_number, \@f);
1094
1095     ++$locales_test_number;
1096     undef @f;
1097     $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1098     for (map { chr } 0..255) {
1099         if ($is_utf8_locale) {
1100             use locale ':not_characters';
1101             push @f, $_  if /[[:upper:]]/ and ! /[[:alpha:]]/;
1102         }
1103         else {
1104             push @f, $_ if /[[:upper:]]/  and ! /[[:alpha:]]/;
1105         }
1106     }
1107     report_multi_result($Locale, $locales_test_number, \@f);
1108
1109     ++$locales_test_number;
1110     undef @f;
1111     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1112     for (map { chr } 0..255) {
1113         if ($is_utf8_locale) {
1114             use locale ':not_characters';
1115             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1116         }
1117         else {
1118             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1119         }
1120     }
1121     report_multi_result($Locale, $locales_test_number, \@f);
1122
1123     ++$locales_test_number;
1124     undef @f;
1125     $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1126     for (map { chr } 0..255) {
1127         if ($is_utf8_locale) {
1128             use locale ':not_characters';
1129             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1130         }
1131         else {
1132             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1133         }
1134     }
1135     report_multi_result($Locale, $locales_test_number, \@f);
1136
1137     ++$locales_test_number;
1138     undef @f;
1139     $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1140     for (map { chr } 0..255) {
1141         if ($is_utf8_locale) {
1142             use locale ':not_characters';
1143             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1144         }
1145         else {
1146             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1147         }
1148     }
1149     report_multi_result($Locale, $locales_test_number, \@f);
1150
1151     ++$locales_test_number;
1152     undef @f;
1153     $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1154     report_result($Locale, $locales_test_number, @Digit_ == 10 || @Digit_ ==20);
1155
1156     ++$locales_test_number;
1157     undef @f;
1158     $test_names{$locales_test_number} = 'Verify that [:digit:] (if is 10 code points) is a subset of [:xdigit:]';
1159     if (@Digit_ == 10) {
1160         for (map { chr } 0..255) {
1161             if ($is_utf8_locale) {
1162                 use locale ':not_characters';
1163                 push @f, $_ if /[[:digit:]]/  and ! /[[:xdigit:]]/;
1164             }
1165             else {
1166                 push @f, $_ if /[[:digit:]]/  and ! /[[:xdigit:]]/;
1167             }
1168         }
1169     }
1170     report_multi_result($Locale, $locales_test_number, \@f);
1171
1172     ++$locales_test_number;
1173     undef @f;
1174     $test_names{$locales_test_number} = 'Verify that [:alnum:] is a subset of [:graph:]';
1175     for (map { chr } 0..255) {
1176         if ($is_utf8_locale) {
1177             use locale ':not_characters';
1178             push @f, $_ if /[[:alnum:]]/  and ! /[[:graph:]]/;
1179         }
1180         else {
1181             push @f, $_ if /[[:alnum:]]/  and ! /[[:graph:]]/;
1182         }
1183     }
1184     report_multi_result($Locale, $locales_test_number, \@f);
1185
1186     # Note that xdigit doesn't have to be a subset of alnum
1187
1188     ++$locales_test_number;
1189     undef @f;
1190     $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1191     for (map { chr } 0..255) {
1192         if ($is_utf8_locale) {
1193             use locale ':not_characters';
1194             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1195         }
1196         else {
1197             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1198         }
1199     }
1200     report_multi_result($Locale, $locales_test_number, \@f);
1201
1202     ++$locales_test_number;
1203     undef @f;
1204     $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1205     for (map { chr } 0..255) {
1206         if ($is_utf8_locale) {
1207             use locale ':not_characters';
1208             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1209         }
1210         else {
1211             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1212         }
1213     }
1214     report_multi_result($Locale, $locales_test_number, \@f);
1215
1216     ++$locales_test_number;
1217     undef @f;
1218     $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1219     for (map { chr } 0..255) {
1220         if ($is_utf8_locale) {
1221             use locale ':not_characters';
1222             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1223         }
1224         else {
1225             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1226         }
1227     }
1228     report_multi_result($Locale, $locales_test_number, \@f);
1229
1230     ++$locales_test_number;
1231     undef @f;
1232     $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1233     for (map { chr } 0..255) {
1234         if ($is_utf8_locale) {
1235             use locale ':not_characters';
1236             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1237         }
1238         else {
1239             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1240         }
1241     }
1242     report_multi_result($Locale, $locales_test_number, \@f);
1243
1244     ++$locales_test_number;
1245     undef @f;
1246     $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1247     for (map { chr } 0..255) {
1248         if ($is_utf8_locale) {
1249             use locale ':not_characters';
1250             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1251         }
1252         else {
1253             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1254         }
1255     }
1256     report_multi_result($Locale, $locales_test_number, \@f);
1257
1258     ++$locales_test_number;
1259     undef @f;
1260     $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1261     for (map { chr } 0..255) {
1262         if ($is_utf8_locale) {
1263             use locale ':not_characters';
1264             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1265         }
1266         else {
1267             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1268         }
1269     }
1270     report_multi_result($Locale, $locales_test_number, \@f);
1271
1272     ++$locales_test_number;
1273     undef @f;
1274     $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1275     for (map { chr } 0..255) {
1276         if ($is_utf8_locale) {
1277             use locale ':not_characters';
1278             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1279         }
1280         else {
1281             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1282         }
1283     }
1284     report_multi_result($Locale, $locales_test_number, \@f);
1285
1286     ++$locales_test_number;
1287     undef @f;
1288     $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1289     for (map { chr } 0..255) {
1290         if ($is_utf8_locale) {
1291             use locale ':not_characters';
1292             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1293         }
1294         else {
1295             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1296         }
1297     }
1298     report_multi_result($Locale, $locales_test_number, \@f);
1299
1300     $final_casing_test_number = $locales_test_number;
1301
1302     # Test for read-only scalars' locale vs non-locale comparisons.
1303
1304     {
1305         no locale;
1306         my $ok;
1307         $a = "qwerty";
1308         if ($is_utf8_locale) {
1309             use locale ':not_characters';
1310             $ok = ($a cmp "qwerty") == 0;
1311         }
1312         else {
1313             use locale;
1314             $ok = ($a cmp "qwerty") == 0;
1315         }
1316         report_result($Locale, ++$locales_test_number, $ok);
1317         $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1318     }
1319
1320     {
1321         my ($from, $to, $lesser, $greater,
1322             @test, %test, $test, $yes, $no, $sign);
1323
1324         ++$locales_test_number;
1325         $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1326         $not_necessarily_a_problem_test_number = $locales_test_number;
1327         for (0..9) {
1328             # Select a slice.
1329             $from = int(($_*@Word_)/10);
1330             $to = $from + int(@Word_/10);
1331             $to = $#Word_ if ($to > $#Word_);
1332             $lesser  = join('', @Word_[$from..$to]);
1333             # Select a slice one character on.
1334             $from++; $to++;
1335             $to = $#Word_ if ($to > $#Word_);
1336             $greater = join('', @Word_[$from..$to]);
1337             if ($is_utf8_locale) {
1338                 use locale ':not_characters';
1339                 ($yes, $no, $sign) = ($lesser lt $greater
1340                                     ? ("    ", "not ", 1)
1341                                     : ("not ", "    ", -1));
1342             }
1343             else {
1344                 use locale;
1345                 ($yes, $no, $sign) = ($lesser lt $greater
1346                                     ? ("    ", "not ", 1)
1347                                     : ("not ", "    ", -1));
1348             }
1349             # all these tests should FAIL (return 0).  Exact lt or gt cannot
1350             # be tested because in some locales, say, eacute and E may test
1351             # equal.
1352             @test =
1353                 (
1354                     $no.'    ($lesser  le $greater)',  # 1
1355                     'not      ($lesser  ne $greater)', # 2
1356                     '         ($lesser  eq $greater)', # 3
1357                     $yes.'    ($lesser  ge $greater)', # 4
1358                     $yes.'    ($lesser  ge $greater)', # 5
1359                     $yes.'    ($greater le $lesser )', # 7
1360                     'not      ($greater ne $lesser )', # 8
1361                     '         ($greater eq $lesser )', # 9
1362                     $no.'     ($greater ge $lesser )', # 10
1363                     'not (($lesser cmp $greater) == -($sign))' # 11
1364                     );
1365             @test{@test} = 0 x @test;
1366             $test = 0;
1367             for my $ti (@test) {
1368                 if ($is_utf8_locale) {
1369                     use locale ':not_characters';
1370                     $test{$ti} = eval $ti;
1371                 }
1372                 else {
1373                     # Already in 'use locale';
1374                     $test{$ti} = eval $ti;
1375                 }
1376                 $test ||= $test{$ti}
1377             }
1378             report_result($Locale, $locales_test_number, $test == 0);
1379             if ($test) {
1380                 debug "# lesser  = '$lesser'\n";
1381                 debug "# greater = '$greater'\n";
1382                 debug "# lesser cmp greater = ",
1383                         $lesser cmp $greater, "\n";
1384                 debug "# greater cmp lesser = ",
1385                         $greater cmp $lesser, "\n";
1386                 debug "# (greater) from = $from, to = $to\n";
1387                 for my $ti (@test) {
1388                     debugf("# %-40s %-4s", $ti,
1389                             $test{$ti} ? 'FAIL' : 'ok');
1390                     if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1391                         debugf("(%s == %4d)", $1, eval $1);
1392                     }
1393                     debug "\n#";
1394                 }
1395
1396                 last;
1397             }
1398         }
1399     }
1400
1401     my $ok1;
1402     my $ok2;
1403     my $ok3;
1404     my $ok4;
1405     my $ok5;
1406     my $ok6;
1407     my $ok7;
1408     my $ok8;
1409     my $ok9;
1410     my $ok10;
1411     my $ok11;
1412     my $ok12;
1413     my $ok13;
1414     my $ok14;
1415     my $ok15;
1416     my $ok16;
1417
1418     my $c;
1419     my $d;
1420     my $e;
1421     my $f;
1422     my $g;
1423
1424     if (! $is_utf8_locale) {
1425         use locale;
1426
1427         my ($x, $y) = (1.23, 1.23);
1428
1429         $a = "$x";
1430         printf ''; # printf used to reset locale to "C"
1431         $b = "$y";
1432         $ok1 = $a eq $b;
1433
1434         $c = "$x";
1435         my $z = sprintf ''; # sprintf used to reset locale to "C"
1436         $d = "$y";
1437         $ok2 = $c eq $d;
1438         {
1439
1440             use warnings;
1441             my $w = 0;
1442             local $SIG{__WARN__} =
1443                 sub {
1444                     print "# @_\n";
1445                     $w++;
1446                 };
1447
1448             # The == (among other ops) used to warn for locales
1449             # that had something else than "." as the radix character.
1450
1451             $ok3 = $c == 1.23;
1452             $ok4 = $c == $x;
1453             $ok5 = $c == $d;
1454             {
1455                 no locale;
1456
1457                 $e = "$x";
1458
1459                 $ok6 = $e == 1.23;
1460                 $ok7 = $e == $x;
1461                 $ok8 = $e == $c;
1462             }
1463
1464             $f = "1.23";
1465             $g = 2.34;
1466
1467             $ok9 = $f == 1.23;
1468             $ok10 = $f == $x;
1469             $ok11 = $f == $c;
1470             $ok12 = abs(($f + $g) - 3.57) < 0.01;
1471             $ok13 = $w == 0;
1472             $ok14 = $ok15 = $ok16 = 1;  # Skip for non-utf8 locales
1473         }
1474     }
1475     else {
1476         use locale ':not_characters';
1477
1478         my ($x, $y) = (1.23, 1.23);
1479         $a = "$x";
1480         printf ''; # printf used to reset locale to "C"
1481         $b = "$y";
1482         $ok1 = $a eq $b;
1483
1484         $c = "$x";
1485         my $z = sprintf ''; # sprintf used to reset locale to "C"
1486         $d = "$y";
1487         $ok2 = $c eq $d;
1488         {
1489             use warnings;
1490             my $w = 0;
1491             local $SIG{__WARN__} =
1492                 sub {
1493                     print "# @_\n";
1494                     $w++;
1495                 };
1496             $ok3 = $c == 1.23;
1497             $ok4 = $c == $x;
1498             $ok5 = $c == $d;
1499             {
1500                 no locale;
1501                 $e = "$x";
1502
1503                 $ok6 = $e == 1.23;
1504                 $ok7 = $e == $x;
1505                 $ok8 = $e == $c;
1506             }
1507
1508             $f = "1.23";
1509             $g = 2.34;
1510
1511             $ok9 = $f == 1.23;
1512             $ok10 = $f == $x;
1513             $ok11 = $f == $c;
1514             $ok12 = abs(($f + $g) - 3.57) < 0.01;
1515             $ok13 = $w == 0;
1516
1517             # Look for non-ASCII error messages, and verify that the first
1518             # such is in UTF-8 (the others almost certainly will be like the
1519             # first).
1520             $ok14 = 1;
1521             foreach my $err (keys %!) {
1522                 use Errno;
1523                 $! = eval "&Errno::$err";   # Convert to strerror() output
1524                 my $strerror = "$!";
1525                 if ("$strerror" =~ /\P{ASCII}/) {
1526                     my $utf8_strerror = $strerror;
1527                     utf8::upgrade($utf8_strerror);
1528
1529                     # If $! was already in UTF-8, the upgrade was a no-op;
1530                     # otherwise they will be different byte strings.
1531                     use bytes;
1532                     $ok14 = $utf8_strerror eq $strerror;
1533                     last;
1534                 }
1535             }
1536
1537             # Similarly, we verify that a non-ASCII radix is in UTF-8.  This
1538             # also catches if there is a disparity between sprintf and
1539             # stringification.
1540
1541             my $string_g = "$g";
1542
1543             my $utf8_string_g = "$g";
1544             utf8::upgrade($utf8_string_g);
1545
1546             my $utf8_sprintf_g = sprintf("%g", $g);
1547             utf8::upgrade($utf8_sprintf_g);
1548             use bytes;
1549             $ok15 = $utf8_string_g eq $string_g;
1550             $ok16 = $utf8_sprintf_g eq $string_g;
1551         }
1552     }
1553
1554     report_result($Locale, ++$locales_test_number, $ok1);
1555     $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
1556     my $first_a_test = $locales_test_number;
1557
1558     debug "# $first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
1559
1560     report_result($Locale, ++$locales_test_number, $ok2);
1561     $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
1562
1563     my $first_c_test = $locales_test_number;
1564
1565     report_result($Locale, ++$locales_test_number, $ok3);
1566     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
1567
1568     report_result($Locale, ++$locales_test_number, $ok4);
1569     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
1570
1571     report_result($Locale, ++$locales_test_number, $ok5);
1572     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
1573
1574     debug "# $first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
1575
1576     report_result($Locale, ++$locales_test_number, $ok6);
1577     $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
1578     my $first_e_test = $locales_test_number;
1579
1580     report_result($Locale, ++$locales_test_number, $ok7);
1581     $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
1582
1583     report_result($Locale, ++$locales_test_number, $ok8);
1584     $test_names{$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
1585
1586     debug "# $first_e_test..$locales_test_number: \$e = $e, no locale\n";
1587
1588     report_result($Locale, ++$locales_test_number, $ok9);
1589     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
1590     my $first_f_test = $locales_test_number;
1591
1592     report_result($Locale, ++$locales_test_number, $ok10);
1593     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
1594
1595     report_result($Locale, ++$locales_test_number, $ok11);
1596     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar and an intervening sprintf';
1597
1598     report_result($Locale, ++$locales_test_number, $ok12);
1599     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix can participate in an addition and function call as numeric';
1600
1601     report_result($Locale, ++$locales_test_number, $ok13);
1602     $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
1603
1604     report_result($Locale, ++$locales_test_number, $ok14);
1605     $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
1606
1607     report_result($Locale, ++$locales_test_number, $ok15);
1608     $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
1609
1610     report_result($Locale, ++$locales_test_number, $ok16);
1611     $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
1612
1613     debug "# $first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
1614
1615     # Does taking lc separately differ from taking
1616     # the lc "in-line"?  (This was the bug 19990704.002, change #3568.)
1617     # The bug was in the caching of the 'o'-magic.
1618     if (! $is_utf8_locale) {
1619         use locale;
1620
1621         sub lcA {
1622             my $lc0 = lc $_[0];
1623             my $lc1 = lc $_[1];
1624             return $lc0 cmp $lc1;
1625         }
1626
1627         sub lcB {
1628             return lc($_[0]) cmp lc($_[1]);
1629         }
1630
1631         my $x = "ab";
1632         my $y = "aa";
1633         my $z = "AB";
1634
1635         report_result($Locale, ++$locales_test_number,
1636                     lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
1637                     lcA($x, $z) == 0 && lcB($x, $z) == 0);
1638     }
1639     else {
1640         use locale ':not_characters';
1641
1642         sub lcC {
1643             my $lc0 = lc $_[0];
1644             my $lc1 = lc $_[1];
1645             return $lc0 cmp $lc1;
1646         }
1647
1648         sub lcD {
1649             return lc($_[0]) cmp lc($_[1]);
1650         }
1651
1652         my $x = "ab";
1653         my $y = "aa";
1654         my $z = "AB";
1655
1656         report_result($Locale, ++$locales_test_number,
1657                     lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
1658                     lcC($x, $z) == 0 && lcD($x, $z) == 0);
1659     }
1660     $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
1661
1662     # Does lc of an UPPER (if different from the UPPER) match
1663     # case-insensitively the UPPER, and does the UPPER match
1664     # case-insensitively the lc of the UPPER.  And vice versa.
1665     {
1666         use locale;
1667         no utf8;
1668         my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
1669
1670         my @f = ();
1671         ++$locales_test_number;
1672         $test_names{$locales_test_number} = 'Verify case insensitive matching works';
1673         foreach my $x (sort keys %UPPER) {
1674             if (! $is_utf8_locale) {
1675                 my $y = lc $x;
1676                 next unless uc $y eq $x;
1677                 print "# UPPER $x lc $y ",
1678                         $x =~ /$y/i ? 1 : 0, " ",
1679                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1680                 #
1681                 # If $x and $y contain regular expression characters
1682                 # AND THEY lowercase (/i) to regular expression characters,
1683                 # regcomp() will be mightily confused.  No, the \Q doesn't
1684                 # help here (maybe regex engine internal lowercasing
1685                 # is done after the \Q?)  An example of this happening is
1686                 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
1687                 # the chr(173) (the "[") is the lowercase of the chr(235).
1688                 #
1689                 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
1690                 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
1691                 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
1692                 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
1693                 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
1694                 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
1695                 #
1696                 # Similar things can happen even under (bastardised)
1697                 # non-EBCDIC locales: in many European countries before the
1698                 # advent of ISO 8859-x nationally customised versions of
1699                 # ISO 646 were devised, reusing certain punctuation
1700                 # characters for modified characters needed by the
1701                 # country/language.  For example, the "|" might have
1702                 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
1703                 #
1704                 if ($x =~ $re || $y =~ $re) {
1705                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
1706                     next;
1707                 }
1708                 # With utf8 both will fail since the locale concept
1709                 # of upper/lower does not work well in Unicode.
1710                 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
1711
1712                 # fc is not a locale concept, so Perl uses lc for it.
1713                 push @f, $x unless lc $x eq fc $x;
1714             }
1715             else {
1716                 use locale ':not_characters';
1717                 my $y = lc $x;
1718                 next unless uc $y eq $x;
1719                 print "# UPPER $x lc $y ",
1720                         $x =~ /$y/i ? 1 : 0, " ",
1721                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1722
1723                 # Here, we can fully test things, unlike plain 'use locale',
1724                 # because this form does work well with Unicode
1725                 push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
1726
1727                 # The places where Unicode's lc is different from fc are
1728                 # skipped here by virtue of the 'next unless uc...' line above
1729                 push @f, $x unless lc $x eq fc $x;
1730             }
1731         }
1732
1733         foreach my $x (sort keys %lower) {
1734             if (! $is_utf8_locale) {
1735                 my $y = uc $x;
1736                 next unless lc $y eq $x;
1737                 print "# lower $x uc $y ",
1738                     $x =~ /$y/i ? 1 : 0, " ",
1739                     $y =~ /$x/i ? 1 : 0, "\n" if 0;
1740                 if ($x =~ $re || $y =~ $re) { # See above.
1741                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
1742                     next;
1743                 }
1744                 # With utf8 both will fail since the locale concept
1745                 # of upper/lower does not work well in Unicode.
1746                 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
1747
1748                 push @f, $x unless lc $x eq fc $x;
1749             }
1750             else {
1751                 use locale ':not_characters';
1752                 my $y = uc $x;
1753                 next unless lc $y eq $x;
1754                 print "# lower $x uc $y ",
1755                         $x =~ /$y/i ? 1 : 0, " ",
1756                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1757                 push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
1758
1759                 push @f, $x unless lc $x eq fc $x;
1760             }
1761         }
1762         report_multi_result($Locale, $locales_test_number, \@f);
1763     }
1764
1765     # [perl #109318]
1766     {
1767         my @f = ();
1768         ++$locales_test_number;
1769         $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
1770
1771         my $radix = POSIX::localeconv()->{decimal_point};
1772         my @nums = (
1773              "3.14e+9",  "3${radix}14e+9",  "3.14e-9",  "3${radix}14e-9",
1774             "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
1775         );
1776
1777         if (! $is_utf8_locale) {
1778             use locale;
1779             for my $num (@nums) {
1780                 push @f, $num
1781                     unless sprintf("%g", $num) =~ /3.+14/;
1782             }
1783         }
1784         else {
1785             use locale ':not_characters';
1786             for my $num (@nums) {
1787                 push @f, $num
1788                     unless sprintf("%g", $num) =~ /3.+14/;
1789             }
1790         }
1791
1792         report_result($Locale, $locales_test_number, @f == 0);
1793         if (@f) {
1794             print "# failed $locales_test_number locale '$Locale' numbers @f\n"
1795         }
1796     }
1797 }
1798
1799 my $final_locales_test_number = $locales_test_number;
1800
1801 # Recount the errors.
1802
1803 foreach ($first_locales_test_number..$final_locales_test_number) {
1804     if (%setlocale_failed) {
1805         print "not ";
1806     }
1807     elsif ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
1808         if (defined $not_necessarily_a_problem_test_number
1809             && $_ == $not_necessarily_a_problem_test_number)
1810         {
1811             print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
1812             print "# It usually indicates a problem in the environment,\n";
1813             print "# not in Perl itself.\n";
1814         }
1815         if ($Okay{$_} && ($_ >= $first_casing_test_number
1816                           && $_ <= $final_casing_test_number))
1817         {
1818             # Round to nearest .1%
1819             my $percent_fail = (int(.5 + (1000 * scalar(keys $Problem{$_})
1820                                           / scalar(@Locale))))
1821                                / 10;
1822             if (! $debug && $percent_fail < $acceptable_fold_failure_percentage)
1823             {
1824                 $test_names{$_} .= 'TODO';
1825                 print "# ", 100 - $percent_fail, "% of locales pass the following test, so it is likely that the failures\n";
1826                 print "# are errors in the locale definitions.  The test is marked TODO, as the\n";
1827                 print "# problem is not likely to be Perl's\n";
1828             }
1829         }
1830         print "#\n";
1831         if ($debug) {
1832             print "# The code points that had this failure are given above.  Look for lines\n";
1833             print "# that match 'failed $_'\n";
1834         }
1835         else {
1836             print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
1837             print "# Then look at that output for lines that match 'failed $_'\n";
1838         }
1839         print "not ";
1840     }
1841     print "ok $_";
1842     if (defined $test_names{$_}) {
1843         # If TODO is in the test name, make it thus
1844         my $todo = $test_names{$_} =~ s/TODO\s*//;
1845         print " $test_names{$_}";
1846         print " # TODO" if $todo;
1847     }
1848     print "\n";
1849 }
1850
1851 $test_num = $final_locales_test_number;
1852
1853 {   # perl #115808
1854     use warnings;
1855     my $warned = 0;
1856     local $SIG{__WARN__} = sub {
1857         $warned = $_[0] =~ /uninitialized/;
1858     };
1859     my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
1860     ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
1861 }
1862
1863 # Test that tainting and case changing works on utf8 strings.  These tests are
1864 # placed last to avoid disturbing the hard-coded test numbers that existed at
1865 # the time these were added above this in this file.
1866 # This also tests that locale overrides unicode_strings in the same scope for
1867 # non-utf8 strings.
1868 setlocale(&POSIX::LC_ALL, "C");
1869 {
1870     use locale;
1871     use feature 'unicode_strings';
1872
1873     foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
1874         my @list;   # List of code points to test for $function
1875
1876         # Used to calculate the changed case for ASCII characters by using the
1877         # ord, instead of using one of the functions under test.
1878         my $ascii_case_change_delta;
1879         my $above_latin1_case_change_delta; # Same for the specific ords > 255
1880                                             # that we use
1881
1882         # We test an ASCII character, which should change case and be tainted;
1883         # a Latin1 character, which shouldn't change case under this C locale,
1884         #   and is tainted.
1885         # an above-Latin1 character that when the case is changed would cross
1886         #   the 255/256 boundary, so doesn't change case and isn't tainted
1887         # (the \x{149} is one of these, but changes into 2 characters, the
1888         #   first one of which doesn't cross the boundary.
1889         # the final one in each list is an above-Latin1 character whose case
1890         #   does change, and shouldn't be tainted.  The code below uses its
1891         #   position in its list as a marker to indicate that it, unlike the
1892         #   other code points above ASCII, has a successful case change
1893         if ($function =~ /^u/) {
1894             @list = ("", "a", "\xe0", "\xff", "\x{fb00}", "\x{149}", "\x{101}");
1895             $ascii_case_change_delta = -32;
1896             $above_latin1_case_change_delta = -1;
1897         }
1898         else {
1899             @list = ("", "A", "\xC0", "\x{17F}", "\x{100}");
1900             $ascii_case_change_delta = +32;
1901             $above_latin1_case_change_delta = +1;
1902         }
1903         foreach my $is_utf8_locale (0 .. 1) {
1904             foreach my $j (0 .. $#list) {
1905                 my $char = $list[$j];
1906
1907                 for my $encoded_in_utf8 (0 .. 1) {
1908                     my $should_be;
1909                     my $changed;
1910                     if (! $is_utf8_locale) {
1911                         $should_be = ($j == $#list)
1912                             ? chr(ord($char) + $above_latin1_case_change_delta)
1913                             : (length $char == 0 || ord($char) > 127)
1914                             ? $char
1915                             : chr(ord($char) + $ascii_case_change_delta);
1916
1917                         # This monstrosity is in order to avoid using an eval,
1918                         # which might perturb the results
1919                         $changed = ($function eq "uc")
1920                                     ? uc($char)
1921                                     : ($function eq "ucfirst")
1922                                       ? ucfirst($char)
1923                                       : ($function eq "lc")
1924                                         ? lc($char)
1925                                         : ($function eq "lcfirst")
1926                                           ? lcfirst($char)
1927                                           : ($function eq "fc")
1928                                             ? fc($char)
1929                                             : die("Unexpected function \"$function\"");
1930                     }
1931                     else {
1932                         {
1933                             no locale;
1934
1935                             # For utf8-locales the case changing functions
1936                             # should work just like they do outside of locale.
1937                             # Can use eval here because not testing it when
1938                             # not in locale.
1939                             $should_be = eval "$function('$char')";
1940                             die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if  $@;
1941
1942                         }
1943                         use locale ':not_characters';
1944                         $changed = ($function eq "uc")
1945                                     ? uc($char)
1946                                     : ($function eq "ucfirst")
1947                                       ? ucfirst($char)
1948                                       : ($function eq "lc")
1949                                         ? lc($char)
1950                                         : ($function eq "lcfirst")
1951                                           ? lcfirst($char)
1952                                           : ($function eq "fc")
1953                                             ? fc($char)
1954                                             : die("Unexpected function \"$function\"");
1955                     }
1956                     ok($changed eq $should_be,
1957                         "$function(\"$char\") in C locale "
1958                         . (($is_utf8_locale)
1959                             ? "(use locale ':not_characters'"
1960                             : "(use locale")
1961                         . (($encoded_in_utf8)
1962                             ? "; encoded in utf8)"
1963                             : "; not encoded in utf8)")
1964                         . " should be \"$should_be\", got \"$changed\"");
1965
1966                     # Tainting shouldn't happen for utf8 locales, empty
1967                     # strings, or those characters above 255.
1968                     (! $is_utf8_locale && length($char) > 0 && ord($char) < 256)
1969                     ? check_taint($changed)
1970                     : check_taint_not($changed);
1971
1972                     # Use UTF-8 next time through the loop
1973                     utf8::upgrade($char);
1974                 }
1975             }
1976         }
1977     }
1978 }
1979
1980 # Give final advice.
1981
1982 my $didwarn = 0;
1983
1984 foreach ($first_locales_test_number..$final_locales_test_number) {
1985     if ($Problem{$_}) {
1986         my @f = sort keys %{ $Problem{$_} };
1987         my $f = join(" ", @f);
1988         $f =~ s/(.{50,60}) /$1\n#\t/g;
1989         print
1990             "#\n",
1991             "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
1992             "#\t", $f, "\n#\n",
1993             "# on your system may have errors because the locale test $_\n",
1994             "# \"$test_names{$_}\"\n",
1995             "# failed in ", (@f == 1 ? "that locale" : "those locales"),
1996             ".\n";
1997         print <<EOW;
1998 #
1999 # If your users are not using these locales you are safe for the moment,
2000 # but please report this failure first to perlbug\@perl.com using the
2001 # perlbug script (as described in the INSTALL file) so that the exact
2002 # details of the failures can be sorted out first and then your operating
2003 # system supplier can be alerted about these anomalies.
2004 #
2005 EOW
2006         $didwarn = 1;
2007     }
2008 }
2009
2010 # Tell which locales were okay and which were not.
2011
2012 if ($didwarn) {
2013     my (@s, @F);
2014
2015     foreach my $l (@Locale) {
2016         my $p = 0;
2017         if ($setlocale_failed{$l}) {
2018             $p++;
2019         }
2020         else {
2021             foreach my $t
2022                         ($first_locales_test_number..$final_locales_test_number)
2023             {
2024                 $p++ if $Problem{$t}{$l};
2025             }
2026         }
2027         push @s, $l if $p == 0;
2028         push @F, $l unless $p == 0;
2029     }
2030
2031     if (@s) {
2032         my $s = join(" ", @s);
2033         $s =~ s/(.{50,60}) /$1\n#\t/g;
2034
2035         warn
2036             "# The following locales\n#\n",
2037             "#\t", $s, "\n#\n",
2038             "# tested okay.\n#\n",
2039     } else {
2040         warn "# None of your locales were fully okay.\n";
2041     }
2042
2043     if (@F) {
2044         my $F = join(" ", @F);
2045         $F =~ s/(.{50,60}) /$1\n#\t/g;
2046
2047         warn
2048           "# The following locales\n#\n",
2049           "#\t", $F, "\n#\n",
2050           "# had problems.\n#\n",
2051           "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2052     } else {
2053         warn "# None of your locales were broken.\n";
2054     }
2055 }
2056
2057 print "1..$test_num\n";
2058
2059 # eof