50c6d237b1ff8e31633d7f4a143f43724cca3661
[perl.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 %posixes;
529
530 sub trylocale {
531     my $locale = shift;
532     return if grep { $locale eq $_ } @Locale;
533     return unless setlocale(&POSIX::LC_ALL, $locale);
534     my $badutf8;
535     {
536         local $SIG{__WARN__} = sub {
537             $badutf8 = $_[0] =~ /Malformed UTF-8/;
538         };
539         $Locale =~ /UTF-?8/i;
540     }
541
542     if ($badutf8) {
543         ok(0, "Locale name contains malformed utf8");
544         return;
545     }
546     push @Locale, $locale;
547 }
548
549 sub decode_encodings {
550     my @enc;
551
552     foreach (split(/ /, shift)) {
553         if (/^(\d+)$/) {
554             push @enc, "ISO8859-$1";
555             push @enc, "iso8859$1";     # HP
556             if ($1 eq '1') {
557                  push @enc, "roman8";   # HP
558             }
559         } else {
560             push @enc, $_;
561             push @enc, "$_.UTF-8";
562         }
563     }
564     if ($^O eq 'os390') {
565         push @enc, qw(IBM-037 IBM-819 IBM-1047);
566     }
567
568     return @enc;
569 }
570
571 trylocale("C");
572 trylocale("POSIX");
573 foreach (0..15) {
574     trylocale("ISO8859-$_");
575     trylocale("iso8859$_");
576     trylocale("iso8859-$_");
577     trylocale("iso_8859_$_");
578     trylocale("isolatin$_");
579     trylocale("isolatin-$_");
580     trylocale("iso_latin_$_");
581 }
582
583 # Sanitize the environment so that we can run the external 'locale'
584 # program without the taint mode getting grumpy.
585
586 # $ENV{PATH} is special in VMS.
587 delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
588
589 # Other subversive stuff.
590 delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
591
592 if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
593     while (<LOCALES>) {
594         # It seems that /usr/bin/locale steadfastly outputs 8 bit data, which
595         # ain't great when we're running this testPERL_UNICODE= so that utf8
596         # locales will cause all IO hadles to default to (assume) utf8
597         next unless utf8::valid($_);
598         chomp;
599         trylocale($_);
600     }
601     close(LOCALES);
602 } elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
603 # The SYS$I18N_LOCALE logical name search list was not present on
604 # VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
605     opendir(LOCALES, "SYS\$I18N_LOCALE:");
606     while ($_ = readdir(LOCALES)) {
607         chomp;
608         trylocale($_);
609     }
610     close(LOCALES);
611 } elsif (($^O eq 'openbsd' || $^O eq 'bitrig' ) && -e '/usr/share/locale') {
612
613    # OpenBSD doesn't have a locale executable, so reading /usr/share/locale
614    # is much easier and faster than the last resort method.
615
616     opendir(LOCALES, '/usr/share/locale');
617     while ($_ = readdir(LOCALES)) {
618         chomp;
619         trylocale($_);
620     }
621     close(LOCALES);
622 } else {
623
624     # This is going to be slow.
625
626     foreach my $locale (split(/\n/, $locales)) {
627         my ($locale_name, $language_codes, $country_codes, $encodings) =
628             split(/:/, $locale);
629         my @enc = decode_encodings($encodings);
630         foreach my $loc (split(/ /, $locale_name)) {
631             trylocale($loc);
632             foreach my $enc (@enc) {
633                 trylocale("$loc.$enc");
634             }
635             $loc = lc $loc;
636             foreach my $enc (@enc) {
637                 trylocale("$loc.$enc");
638             }
639         }
640         foreach my $lang (split(/ /, $language_codes)) {
641             trylocale($lang);
642             foreach my $country (split(/ /, $country_codes)) {
643                 my $lc = "${lang}_${country}";
644                 trylocale($lc);
645                 foreach my $enc (@enc) {
646                     trylocale("$lc.$enc");
647                 }
648                 my $lC = "${lang}_\U${country}";
649                 trylocale($lC);
650                 foreach my $enc (@enc) {
651                     trylocale("$lC.$enc");
652                 }
653             }
654         }
655     }
656 }
657
658 setlocale(&POSIX::LC_ALL, "C");
659
660 if ($^O eq 'darwin') {
661     # Darwin 8/Mac OS X 10.4 and 10.5 have bad Basque locales: perl bug #35895,
662     # Apple bug ID# 4139653. It also has a problem in Byelorussian.
663     (my $v) = $Config{osvers} =~ /^(\d+)/;
664     if ($v >= 8 and $v < 10) {
665         debug "# Skipping eu_ES, be_BY locales -- buggy in Darwin\n";
666         @Locale = grep ! m/^(eu_ES(?:\..*)?|be_BY\.CP1131)$/, @Locale;
667     } elsif ($v < 12) {
668         debug "# Skipping be_BY locales -- buggy in Darwin\n";
669         @Locale = grep ! m/^be_BY\.CP1131$/, @Locale;
670     }
671 }
672
673 @Locale = sort @Locale;
674
675 debug "# Locales =\n";
676 for ( @Locale ) {
677     debug "# $_\n";
678 }
679
680 my %Problem;
681 my %Okay;
682 my %Testing;
683 my @Added_alpha;   # Alphas that aren't in the C locale.
684 my %test_names;
685
686 sub display_characters {
687     # This returns a display string denoting the input parameter @_, each
688     # entry of which is a single character in the range 0-255.  The first part
689     # of the output is a string of the characters in @_ that are ASCII
690     # graphics, and hence unambiguously displayable.  They are given by code
691     # point order.  The second part is the remaining code points, the ordinals
692     # of which are each displayed as 2-digit hex.  Blanks are inserted so as
693     # to keep anything from the first part looking like a 2-digit hex number.
694
695     no locale;
696     my @chars = sort { ord $a <=> ord $b } @_;
697     my $output = "";
698     my $hex = "";
699     my $range_start;
700     my $start_class;
701     push @chars, chr(258);  # This sentinel simplifies the loop termination
702                             # logic
703     foreach my $i (0 .. @chars - 1) {
704         my $char = $chars[$i];
705         my $range_end;
706         my $class;
707
708         # We avoid using [:posix:] classes, as these are being tested in this
709         # file.  Each equivalence class below is for things that can appear in
710         # a range; those that can't be in a range have class -1.  0 for those
711         # which should be output in hex; and >0 for the other ranges
712         if ($char =~ /[A-Z]/) {
713             $class = 2;
714         }
715         elsif ($char =~ /[a-z]/) {
716             $class = 3;
717         }
718         elsif ($char =~ /[0-9]/) {
719             $class = 4;
720         }
721         elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
722             $class = -1;    # Punct never appears in a range
723         }
724         else {
725             $class = 0;     # Output in hex
726         }
727
728         if (! defined $range_start) {
729             if ($class < 0) {
730                 $output .= $char;
731             }
732             else {
733                 $range_start = ord $char;
734                 $start_class = $class;
735             }
736         } # A range ends if not consecutive, or the class-type changes
737         elsif (ord $char != ($range_end = ord($chars[$i-1])) + 1
738               || $class != $start_class)
739         {
740
741             # Here, the current character is not in the range.  This means the
742             # previous character must have been.  Output the range up through
743             # that one.
744             my $range_length = $range_end - $range_start + 1;
745             if ($start_class > 0) {
746                 $output .= " " . chr($range_start);
747                 $output .= "-" . chr($range_end) if $range_length > 1;
748             }
749             else {
750                 $hex .= sprintf(" %02X", $range_start);
751                 $hex .= sprintf("-%02X", $range_end) if $range_length > 1;
752             }
753
754             # Handle the new current character, as potentially beginning a new
755             # range
756             undef $range_start;
757             redo;
758         }
759     }
760
761     $output =~ s/^ //;
762     $hex =~ s/^ // if ! length $output;
763     return "$output$hex";
764 }
765
766 sub report_result {
767     my ($Locale, $i, $pass_fail, $message) = @_;
768     $message //= "";
769     $message = "  ($message)" if $message;
770     unless ($pass_fail) {
771         $Problem{$i}{$Locale} = 1;
772         debug "# failed $i ($test_names{$i}) with locale '$Locale'$message\n";
773     } else {
774         push @{$Okay{$i}}, $Locale;
775     }
776 }
777
778 sub report_multi_result {
779     my ($Locale, $i, $results_ref) = @_;
780
781     # $results_ref points to an array, each element of which is a character that was
782     # in error for this test numbered '$i'.  If empty, the test passed
783
784     my $message = "";
785     if (@$results_ref) {
786         $message = join " ", "for", display_characters(@$results_ref);
787     }
788     report_result($Locale, $i, @$results_ref == 0, $message);
789 }
790
791 my $first_locales_test_number = $final_without_setlocale + 1;
792 my $locales_test_number;
793 my $not_necessarily_a_problem_test_number;
794 my $first_casing_test_number;
795 my $final_casing_test_number;
796 my %setlocale_failed;   # List of locales that setlocale() didn't work on
797
798 foreach $Locale (@Locale) {
799     $locales_test_number = $first_locales_test_number - 1;
800     debug "# Locale = $Locale\n";
801
802     unless (setlocale(&POSIX::LC_ALL, $Locale)) {
803         $setlocale_failed{$Locale} = $Locale;
804         next;
805     }
806
807     # We test UTF-8 locales only under ':not_characters'; otherwise they have
808     # documented deficiencies.  Non- UTF-8 locales are tested only under plain
809     # 'use locale', as otherwise we would have to convert everything in them
810     # to Unicode.
811     # The locale name doesn't necessarily have to have "utf8" in it to be a
812     # UTF-8 locale, but it works mostly.
813     my $is_utf8_locale = $Locale =~ /UTF-?8/i;
814
815     my %UPPER = ();     # All alpha X for which uc(X) == X and lc(X) != X
816     my %lower = ();     # All alpha X for which lc(X) == X and uc(X) != X
817     my %BoThCaSe = ();  # All alpha X for which uc(X) == lc(X) == X
818
819     if (! $is_utf8_locale) {
820         use locale;
821         @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
822         @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
823         @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
824         @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
825         @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
826         @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
827         @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
828         @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
829         @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
830         @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
831         @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
832         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
833         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
834         @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
835
836         # Sieve the uppercase and the lowercase.
837
838         for (@{$posixes{'word'}}) {
839             if (/[^\d_]/) { # skip digits and the _
840                 if (uc($_) eq $_) {
841                     $UPPER{$_} = $_;
842                 }
843                 if (lc($_) eq $_) {
844                     $lower{$_} = $_;
845                 }
846             }
847         }
848     }
849     else {
850         use locale ':not_characters';
851         @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
852         @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
853         @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
854         @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
855         @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
856         @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
857         @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
858         @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
859         @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
860         @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
861         @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
862         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
863         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
864         @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
865         for (@{$posixes{'word'}}) {
866             if (/[^\d_]/) { # skip digits and the _
867                 if (uc($_) eq $_) {
868                     $UPPER{$_} = $_;
869                 }
870                 if (lc($_) eq $_) {
871                     $lower{$_} = $_;
872                 }
873             }
874         }
875     }
876
877     # Ordered, where possible,  in groups of "this is a subset of the next
878     # one"
879     debug "# :upper:  = ", display_characters(@{$posixes{'upper'}}), "\n";
880     debug "# :lower:  = ", display_characters(@{$posixes{'lower'}}), "\n";
881     debug "# :cased:  = ", display_characters(@{$posixes{'cased'}}), "\n";
882     debug "# :alpha:  = ", display_characters(@{$posixes{'alpha'}}), "\n";
883     debug "# :alnum:  = ", display_characters(@{$posixes{'alnum'}}), "\n";
884     debug "#  w       = ", display_characters(@{$posixes{'word'}}), "\n";
885     debug "# :graph:  = ", display_characters(@{$posixes{'graph'}}), "\n";
886     debug "# :print:  = ", display_characters(@{$posixes{'print'}}), "\n";
887     debug "#  d       = ", display_characters(@{$posixes{'digit'}}), "\n";
888     debug "# :xdigit: = ", display_characters(@{$posixes{'xdigit'}}), "\n";
889     debug "# :blank:  = ", display_characters(@{$posixes{'blank'}}), "\n";
890     debug "#  s       = ", display_characters(@{$posixes{'space'}}), "\n";
891     debug "# :cntrl:  = ", display_characters(@{$posixes{'cntrl'}}), "\n";
892     debug "# :ascii:  = ", display_characters(@{$posixes{'ascii'}}), "\n";
893
894     foreach (keys %UPPER) {
895
896         $BoThCaSe{$_}++ if exists $lower{$_};
897     }
898     foreach (keys %lower) {
899         $BoThCaSe{$_}++ if exists $UPPER{$_};
900     }
901     foreach (keys %BoThCaSe) {
902         delete $UPPER{$_};
903         delete $lower{$_};
904     }
905
906     debug "# UPPER    = ", display_characters(keys %UPPER), "\n";
907     debug "# lower    = ", display_characters(keys %lower), "\n";
908     debug "# BoThCaSe = ", display_characters(keys %BoThCaSe), "\n";
909
910     my @failures;
911     my @fold_failures;
912     foreach my $x (sort keys %UPPER) {
913         my $ok;
914         my $fold_ok;
915         if ($is_utf8_locale) {
916             use locale ':not_characters';
917             $ok = $x =~ /[[:upper:]]/;
918             $fold_ok = $x =~ /[[:lower:]]/i;
919         }
920         else {
921             use locale;
922             $ok = $x =~ /[[:upper:]]/;
923             $fold_ok = $x =~ /[[:lower:]]/i;
924         }
925         push @failures, $x unless $ok;
926         push @fold_failures, $x unless $fold_ok;
927     }
928     $locales_test_number++;
929     $first_casing_test_number = $locales_test_number;
930     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
931     report_multi_result($Locale, $locales_test_number, \@failures);
932
933     $locales_test_number++;
934
935     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
936     report_multi_result($Locale, $locales_test_number, \@fold_failures);
937
938     undef @failures;
939     undef @fold_failures;
940
941     foreach my $x (sort keys %lower) {
942         my $ok;
943         my $fold_ok;
944         if ($is_utf8_locale) {
945             use locale ':not_characters';
946             $ok = $x =~ /[[:lower:]]/;
947             $fold_ok = $x =~ /[[:upper:]]/i;
948         }
949         else {
950             use locale;
951             $ok = $x =~ /[[:lower:]]/;
952             $fold_ok = $x =~ /[[:upper:]]/i;
953         }
954         push @failures, $x unless $ok;
955         push @fold_failures, $x unless $fold_ok;
956     }
957
958     $locales_test_number++;
959     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
960     report_multi_result($Locale, $locales_test_number, \@failures);
961
962     $locales_test_number++;
963     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
964     report_multi_result($Locale, $locales_test_number, \@fold_failures);
965
966     {   # Find the alphabetic characters that are not considered alphabetics
967         # in the default (C) locale.
968
969         no locale;
970
971         @Added_alpha = ();
972         for (keys %UPPER, keys %lower, keys %BoThCaSe) {
973             push(@Added_alpha, $_) if (/\W/);
974         }
975     }
976
977     @Added_alpha = sort @Added_alpha;
978
979     debug "# Added_alpha = ", display_characters(@Added_alpha), "\n";
980
981     # Cross-check the whole 8-bit character set.
982
983     ++$locales_test_number;
984     my @f;
985     $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
986     for (map { chr } 0..255) {
987         if ($is_utf8_locale) {
988             use locale ':not_characters';
989             push @f, $_ unless /[[:word:]]/ == /\w/;
990         }
991         else {
992             push @f, $_ unless /[[:word:]]/ == /\w/;
993         }
994     }
995     report_multi_result($Locale, $locales_test_number, \@f);
996
997     ++$locales_test_number;
998     undef @f;
999     $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1000     for (map { chr } 0..255) {
1001         if ($is_utf8_locale) {
1002             use locale ':not_characters';
1003             push @f, $_ unless /[[:digit:]]/ == /\d/;
1004         }
1005         else {
1006             push @f, $_ unless /[[:digit:]]/ == /\d/;
1007         }
1008     }
1009     report_multi_result($Locale, $locales_test_number, \@f);
1010
1011     ++$locales_test_number;
1012     undef @f;
1013     $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1014     for (map { chr } 0..255) {
1015         if ($is_utf8_locale) {
1016             use locale ':not_characters';
1017             push @f, $_ unless /[[:space:]]/ == /\s/;
1018         }
1019         else {
1020             push @f, $_ unless /[[:space:]]/ == /\s/;
1021         }
1022     }
1023     report_multi_result($Locale, $locales_test_number, \@f);
1024
1025     ++$locales_test_number;
1026     undef @f;
1027     $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1028     for (map { chr } 0..255) {
1029         if ($is_utf8_locale) {
1030             use locale ':not_characters';
1031             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1032                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1033                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1034                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1035                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1036                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1037                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1038                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1039                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1040                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1041                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1042                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1043                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1044
1045                     # effectively is what [:cased:] would be if it existed.
1046                     (/[[:upper:]]/i xor /[[:^upper:]]/i);
1047         }
1048         else {
1049             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1050                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1051                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1052                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1053                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1054                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1055                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1056                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1057                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1058                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1059                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1060                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1061                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1062                     (/[[:upper:]]/i xor /[[:^upper:]]/i);
1063         }
1064     }
1065     report_multi_result($Locale, $locales_test_number, \@f);
1066
1067     # The rules for the relationships are given in:
1068     # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1069
1070     ++$locales_test_number;
1071     undef @f;
1072     $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1073     for (map { chr } 0..255) {
1074         if ($is_utf8_locale) {
1075             use locale ':not_characters';
1076             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1077         }
1078         else {
1079             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1080         }
1081     }
1082     report_multi_result($Locale, $locales_test_number, \@f);
1083
1084     ++$locales_test_number;
1085     undef @f;
1086     $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1087     for (map { chr } 0..255) {
1088         if ($is_utf8_locale) {
1089             use locale ':not_characters';
1090             push @f, $_  if /[[:upper:]]/ and ! /[[:alpha:]]/;
1091         }
1092         else {
1093             push @f, $_ if /[[:upper:]]/  and ! /[[:alpha:]]/;
1094         }
1095     }
1096     report_multi_result($Locale, $locales_test_number, \@f);
1097
1098     ++$locales_test_number;
1099     undef @f;
1100     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1101     for (map { chr } 0..255) {
1102         if ($is_utf8_locale) {
1103             use locale ':not_characters';
1104             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1105         }
1106         else {
1107             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1108         }
1109     }
1110     report_multi_result($Locale, $locales_test_number, \@f);
1111
1112     ++$locales_test_number;
1113     undef @f;
1114     $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1115     for (map { chr } 0..255) {
1116         if ($is_utf8_locale) {
1117             use locale ':not_characters';
1118             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1119         }
1120         else {
1121             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1122         }
1123     }
1124     report_multi_result($Locale, $locales_test_number, \@f);
1125
1126     ++$locales_test_number;
1127     undef @f;
1128     $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1129     for (map { chr } 0..255) {
1130         if ($is_utf8_locale) {
1131             use locale ':not_characters';
1132             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1133         }
1134         else {
1135             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1136         }
1137     }
1138     report_multi_result($Locale, $locales_test_number, \@f);
1139
1140     ++$locales_test_number;
1141     undef @f;
1142     $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1143     report_result($Locale, $locales_test_number, @{$posixes{'digit'}} == 10 || @{$posixes{'digit'}} == 20);
1144
1145     ++$locales_test_number;
1146     undef @f;
1147     $test_names{$locales_test_number} = 'Verify that [:digit:] (if is 10 code points) is a subset of [:xdigit:]';
1148     if (@{$posixes{'digit'}} == 10) {
1149         for (map { chr } 0..255) {
1150             if ($is_utf8_locale) {
1151                 use locale ':not_characters';
1152                 push @f, $_ if /[[:digit:]]/  and ! /[[:xdigit:]]/;
1153             }
1154             else {
1155                 push @f, $_ if /[[:digit:]]/  and ! /[[:xdigit:]]/;
1156             }
1157         }
1158     }
1159     report_multi_result($Locale, $locales_test_number, \@f);
1160
1161     ++$locales_test_number;
1162     undef @f;
1163     $test_names{$locales_test_number} = 'Verify that [:alnum:] is a subset of [:graph:]';
1164     for (map { chr } 0..255) {
1165         if ($is_utf8_locale) {
1166             use locale ':not_characters';
1167             push @f, $_ if /[[:alnum:]]/  and ! /[[:graph:]]/;
1168         }
1169         else {
1170             push @f, $_ if /[[:alnum:]]/  and ! /[[:graph:]]/;
1171         }
1172     }
1173     report_multi_result($Locale, $locales_test_number, \@f);
1174
1175     # Note that xdigit doesn't have to be a subset of alnum
1176
1177     ++$locales_test_number;
1178     undef @f;
1179     $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1180     for (map { chr } 0..255) {
1181         if ($is_utf8_locale) {
1182             use locale ':not_characters';
1183             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1184         }
1185         else {
1186             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1187         }
1188     }
1189     report_multi_result($Locale, $locales_test_number, \@f);
1190
1191     ++$locales_test_number;
1192     undef @f;
1193     $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1194     for (map { chr } 0..255) {
1195         if ($is_utf8_locale) {
1196             use locale ':not_characters';
1197             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1198         }
1199         else {
1200             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1201         }
1202     }
1203     report_multi_result($Locale, $locales_test_number, \@f);
1204
1205     ++$locales_test_number;
1206     undef @f;
1207     $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1208     for (map { chr } 0..255) {
1209         if ($is_utf8_locale) {
1210             use locale ':not_characters';
1211             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1212         }
1213         else {
1214             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1215         }
1216     }
1217     report_multi_result($Locale, $locales_test_number, \@f);
1218
1219     ++$locales_test_number;
1220     undef @f;
1221     $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1222     for (map { chr } 0..255) {
1223         if ($is_utf8_locale) {
1224             use locale ':not_characters';
1225             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1226         }
1227         else {
1228             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1229         }
1230     }
1231     report_multi_result($Locale, $locales_test_number, \@f);
1232
1233     ++$locales_test_number;
1234     undef @f;
1235     $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1236     for (map { chr } 0..255) {
1237         if ($is_utf8_locale) {
1238             use locale ':not_characters';
1239             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1240         }
1241         else {
1242             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1243         }
1244     }
1245     report_multi_result($Locale, $locales_test_number, \@f);
1246
1247     ++$locales_test_number;
1248     undef @f;
1249     $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1250     for (map { chr } 0..255) {
1251         if ($is_utf8_locale) {
1252             use locale ':not_characters';
1253             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1254         }
1255         else {
1256             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1257         }
1258     }
1259     report_multi_result($Locale, $locales_test_number, \@f);
1260
1261     ++$locales_test_number;
1262     undef @f;
1263     $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1264     for (map { chr } 0..255) {
1265         if ($is_utf8_locale) {
1266             use locale ':not_characters';
1267             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1268         }
1269         else {
1270             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1271         }
1272     }
1273     report_multi_result($Locale, $locales_test_number, \@f);
1274
1275     ++$locales_test_number;
1276     undef @f;
1277     $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1278     for (map { chr } 0..255) {
1279         if ($is_utf8_locale) {
1280             use locale ':not_characters';
1281             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1282         }
1283         else {
1284             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1285         }
1286     }
1287     report_multi_result($Locale, $locales_test_number, \@f);
1288
1289     $final_casing_test_number = $locales_test_number;
1290
1291     # Test for read-only scalars' locale vs non-locale comparisons.
1292
1293     {
1294         no locale;
1295         my $ok;
1296         $a = "qwerty";
1297         if ($is_utf8_locale) {
1298             use locale ':not_characters';
1299             $ok = ($a cmp "qwerty") == 0;
1300         }
1301         else {
1302             use locale;
1303             $ok = ($a cmp "qwerty") == 0;
1304         }
1305         report_result($Locale, ++$locales_test_number, $ok);
1306         $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1307     }
1308
1309     {
1310         my ($from, $to, $lesser, $greater,
1311             @test, %test, $test, $yes, $no, $sign);
1312
1313         ++$locales_test_number;
1314         $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1315         $not_necessarily_a_problem_test_number = $locales_test_number;
1316         for (0..9) {
1317             # Select a slice.
1318             $from = int(($_*@{$posixes{'word'}})/10);
1319             $to = $from + int(@{$posixes{'word'}}/10);
1320             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1321             $lesser  = join('', @{$posixes{'word'}}[$from..$to]);
1322             # Select a slice one character on.
1323             $from++; $to++;
1324             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1325             $greater = join('', @{$posixes{'word'}}[$from..$to]);
1326             if ($is_utf8_locale) {
1327                 use locale ':not_characters';
1328                 ($yes, $no, $sign) = ($lesser lt $greater
1329                                     ? ("    ", "not ", 1)
1330                                     : ("not ", "    ", -1));
1331             }
1332             else {
1333                 use locale;
1334                 ($yes, $no, $sign) = ($lesser lt $greater
1335                                     ? ("    ", "not ", 1)
1336                                     : ("not ", "    ", -1));
1337             }
1338             # all these tests should FAIL (return 0).  Exact lt or gt cannot
1339             # be tested because in some locales, say, eacute and E may test
1340             # equal.
1341             @test =
1342                 (
1343                     $no.'    ($lesser  le $greater)',  # 1
1344                     'not      ($lesser  ne $greater)', # 2
1345                     '         ($lesser  eq $greater)', # 3
1346                     $yes.'    ($lesser  ge $greater)', # 4
1347                     $yes.'    ($lesser  ge $greater)', # 5
1348                     $yes.'    ($greater le $lesser )', # 7
1349                     'not      ($greater ne $lesser )', # 8
1350                     '         ($greater eq $lesser )', # 9
1351                     $no.'     ($greater ge $lesser )', # 10
1352                     'not (($lesser cmp $greater) == -($sign))' # 11
1353                     );
1354             @test{@test} = 0 x @test;
1355             $test = 0;
1356             for my $ti (@test) {
1357                 if ($is_utf8_locale) {
1358                     use locale ':not_characters';
1359                     $test{$ti} = eval $ti;
1360                 }
1361                 else {
1362                     # Already in 'use locale';
1363                     $test{$ti} = eval $ti;
1364                 }
1365                 $test ||= $test{$ti}
1366             }
1367             report_result($Locale, $locales_test_number, $test == 0);
1368             if ($test) {
1369                 debug "# lesser  = '$lesser'\n";
1370                 debug "# greater = '$greater'\n";
1371                 debug "# lesser cmp greater = ",
1372                         $lesser cmp $greater, "\n";
1373                 debug "# greater cmp lesser = ",
1374                         $greater cmp $lesser, "\n";
1375                 debug "# (greater) from = $from, to = $to\n";
1376                 for my $ti (@test) {
1377                     debugf("# %-40s %-4s", $ti,
1378                             $test{$ti} ? 'FAIL' : 'ok');
1379                     if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1380                         debugf("(%s == %4d)", $1, eval $1);
1381                     }
1382                     debug "\n#";
1383                 }
1384
1385                 last;
1386             }
1387         }
1388     }
1389
1390     my $ok1;
1391     my $ok2;
1392     my $ok3;
1393     my $ok4;
1394     my $ok5;
1395     my $ok6;
1396     my $ok7;
1397     my $ok8;
1398     my $ok9;
1399     my $ok10;
1400     my $ok11;
1401     my $ok12;
1402     my $ok13;
1403     my $ok14;
1404     my $ok15;
1405     my $ok16;
1406
1407     my $c;
1408     my $d;
1409     my $e;
1410     my $f;
1411     my $g;
1412
1413     if (! $is_utf8_locale) {
1414         use locale;
1415
1416         my ($x, $y) = (1.23, 1.23);
1417
1418         $a = "$x";
1419         printf ''; # printf used to reset locale to "C"
1420         $b = "$y";
1421         $ok1 = $a eq $b;
1422
1423         $c = "$x";
1424         my $z = sprintf ''; # sprintf used to reset locale to "C"
1425         $d = "$y";
1426         $ok2 = $c eq $d;
1427         {
1428
1429             use warnings;
1430             my $w = 0;
1431             local $SIG{__WARN__} =
1432                 sub {
1433                     print "# @_\n";
1434                     $w++;
1435                 };
1436
1437             # The == (among other ops) used to warn for locales
1438             # that had something else than "." as the radix character.
1439
1440             $ok3 = $c == 1.23;
1441             $ok4 = $c == $x;
1442             $ok5 = $c == $d;
1443             {
1444                 no locale;
1445
1446                 $e = "$x";
1447
1448                 $ok6 = $e == 1.23;
1449                 $ok7 = $e == $x;
1450                 $ok8 = $e == $c;
1451             }
1452
1453             $f = "1.23";
1454             $g = 2.34;
1455
1456             $ok9 = $f == 1.23;
1457             $ok10 = $f == $x;
1458             $ok11 = $f == $c;
1459             $ok12 = abs(($f + $g) - 3.57) < 0.01;
1460             $ok13 = $w == 0;
1461             $ok14 = $ok15 = $ok16 = 1;  # Skip for non-utf8 locales
1462         }
1463     }
1464     else {
1465         use locale ':not_characters';
1466
1467         my ($x, $y) = (1.23, 1.23);
1468         $a = "$x";
1469         printf ''; # printf used to reset locale to "C"
1470         $b = "$y";
1471         $ok1 = $a eq $b;
1472
1473         $c = "$x";
1474         my $z = sprintf ''; # sprintf used to reset locale to "C"
1475         $d = "$y";
1476         $ok2 = $c eq $d;
1477         {
1478             use warnings;
1479             my $w = 0;
1480             local $SIG{__WARN__} =
1481                 sub {
1482                     print "# @_\n";
1483                     $w++;
1484                 };
1485             $ok3 = $c == 1.23;
1486             $ok4 = $c == $x;
1487             $ok5 = $c == $d;
1488             {
1489                 no locale;
1490                 $e = "$x";
1491
1492                 $ok6 = $e == 1.23;
1493                 $ok7 = $e == $x;
1494                 $ok8 = $e == $c;
1495             }
1496
1497             $f = "1.23";
1498             $g = 2.34;
1499
1500             $ok9 = $f == 1.23;
1501             $ok10 = $f == $x;
1502             $ok11 = $f == $c;
1503             $ok12 = abs(($f + $g) - 3.57) < 0.01;
1504             $ok13 = $w == 0;
1505
1506             # Look for non-ASCII error messages, and verify that the first
1507             # such is in UTF-8 (the others almost certainly will be like the
1508             # first).
1509             $ok14 = 1;
1510             foreach my $err (keys %!) {
1511                 use Errno;
1512                 $! = eval "&Errno::$err";   # Convert to strerror() output
1513                 my $strerror = "$!";
1514                 if ("$strerror" =~ /\P{ASCII}/) {
1515                     my $utf8_strerror = $strerror;
1516                     utf8::upgrade($utf8_strerror);
1517
1518                     # If $! was already in UTF-8, the upgrade was a no-op;
1519                     # otherwise they will be different byte strings.
1520                     use bytes;
1521                     $ok14 = $utf8_strerror eq $strerror;
1522                     last;
1523                 }
1524             }
1525
1526             # Similarly, we verify that a non-ASCII radix is in UTF-8.  This
1527             # also catches if there is a disparity between sprintf and
1528             # stringification.
1529
1530             my $string_g = "$g";
1531
1532             my $utf8_string_g = "$g";
1533             utf8::upgrade($utf8_string_g);
1534
1535             my $utf8_sprintf_g = sprintf("%g", $g);
1536             utf8::upgrade($utf8_sprintf_g);
1537             use bytes;
1538             $ok15 = $utf8_string_g eq $string_g;
1539             $ok16 = $utf8_sprintf_g eq $string_g;
1540         }
1541     }
1542
1543     report_result($Locale, ++$locales_test_number, $ok1);
1544     $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
1545     my $first_a_test = $locales_test_number;
1546
1547     debug "# $first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
1548
1549     report_result($Locale, ++$locales_test_number, $ok2);
1550     $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
1551
1552     my $first_c_test = $locales_test_number;
1553
1554     report_result($Locale, ++$locales_test_number, $ok3);
1555     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
1556
1557     report_result($Locale, ++$locales_test_number, $ok4);
1558     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
1559
1560     report_result($Locale, ++$locales_test_number, $ok5);
1561     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
1562
1563     debug "# $first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
1564
1565     report_result($Locale, ++$locales_test_number, $ok6);
1566     $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
1567     my $first_e_test = $locales_test_number;
1568
1569     report_result($Locale, ++$locales_test_number, $ok7);
1570     $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
1571
1572     report_result($Locale, ++$locales_test_number, $ok8);
1573     $test_names{$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
1574
1575     debug "# $first_e_test..$locales_test_number: \$e = $e, no locale\n";
1576
1577     report_result($Locale, ++$locales_test_number, $ok9);
1578     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
1579     my $first_f_test = $locales_test_number;
1580
1581     report_result($Locale, ++$locales_test_number, $ok10);
1582     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
1583
1584     report_result($Locale, ++$locales_test_number, $ok11);
1585     $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';
1586
1587     report_result($Locale, ++$locales_test_number, $ok12);
1588     $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';
1589
1590     report_result($Locale, ++$locales_test_number, $ok13);
1591     $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
1592
1593     report_result($Locale, ++$locales_test_number, $ok14);
1594     $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
1595
1596     report_result($Locale, ++$locales_test_number, $ok15);
1597     $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
1598
1599     report_result($Locale, ++$locales_test_number, $ok16);
1600     $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
1601
1602     debug "# $first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
1603
1604     # Does taking lc separately differ from taking
1605     # the lc "in-line"?  (This was the bug 19990704.002, change #3568.)
1606     # The bug was in the caching of the 'o'-magic.
1607     if (! $is_utf8_locale) {
1608         use locale;
1609
1610         sub lcA {
1611             my $lc0 = lc $_[0];
1612             my $lc1 = lc $_[1];
1613             return $lc0 cmp $lc1;
1614         }
1615
1616         sub lcB {
1617             return lc($_[0]) cmp lc($_[1]);
1618         }
1619
1620         my $x = "ab";
1621         my $y = "aa";
1622         my $z = "AB";
1623
1624         report_result($Locale, ++$locales_test_number,
1625                     lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
1626                     lcA($x, $z) == 0 && lcB($x, $z) == 0);
1627     }
1628     else {
1629         use locale ':not_characters';
1630
1631         sub lcC {
1632             my $lc0 = lc $_[0];
1633             my $lc1 = lc $_[1];
1634             return $lc0 cmp $lc1;
1635         }
1636
1637         sub lcD {
1638             return lc($_[0]) cmp lc($_[1]);
1639         }
1640
1641         my $x = "ab";
1642         my $y = "aa";
1643         my $z = "AB";
1644
1645         report_result($Locale, ++$locales_test_number,
1646                     lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
1647                     lcC($x, $z) == 0 && lcD($x, $z) == 0);
1648     }
1649     $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
1650
1651     # Does lc of an UPPER (if different from the UPPER) match
1652     # case-insensitively the UPPER, and does the UPPER match
1653     # case-insensitively the lc of the UPPER.  And vice versa.
1654     {
1655         use locale;
1656         no utf8;
1657         my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
1658
1659         my @f = ();
1660         ++$locales_test_number;
1661         $test_names{$locales_test_number} = 'Verify case insensitive matching works';
1662         foreach my $x (sort keys %UPPER) {
1663             if (! $is_utf8_locale) {
1664                 my $y = lc $x;
1665                 next unless uc $y eq $x;
1666                 print "# UPPER $x lc $y ",
1667                         $x =~ /$y/i ? 1 : 0, " ",
1668                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1669                 #
1670                 # If $x and $y contain regular expression characters
1671                 # AND THEY lowercase (/i) to regular expression characters,
1672                 # regcomp() will be mightily confused.  No, the \Q doesn't
1673                 # help here (maybe regex engine internal lowercasing
1674                 # is done after the \Q?)  An example of this happening is
1675                 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
1676                 # the chr(173) (the "[") is the lowercase of the chr(235).
1677                 #
1678                 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
1679                 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
1680                 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
1681                 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
1682                 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
1683                 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
1684                 #
1685                 # Similar things can happen even under (bastardised)
1686                 # non-EBCDIC locales: in many European countries before the
1687                 # advent of ISO 8859-x nationally customised versions of
1688                 # ISO 646 were devised, reusing certain punctuation
1689                 # characters for modified characters needed by the
1690                 # country/language.  For example, the "|" might have
1691                 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
1692                 #
1693                 if ($x =~ $re || $y =~ $re) {
1694                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
1695                     next;
1696                 }
1697                 # With utf8 both will fail since the locale concept
1698                 # of upper/lower does not work well in Unicode.
1699                 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
1700
1701                 # fc is not a locale concept, so Perl uses lc for it.
1702                 push @f, $x unless lc $x eq fc $x;
1703             }
1704             else {
1705                 use locale ':not_characters';
1706                 my $y = lc $x;
1707                 next unless uc $y eq $x;
1708                 print "# UPPER $x lc $y ",
1709                         $x =~ /$y/i ? 1 : 0, " ",
1710                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1711
1712                 # Here, we can fully test things, unlike plain 'use locale',
1713                 # because this form does work well with Unicode
1714                 push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
1715
1716                 # The places where Unicode's lc is different from fc are
1717                 # skipped here by virtue of the 'next unless uc...' line above
1718                 push @f, $x unless lc $x eq fc $x;
1719             }
1720         }
1721
1722         foreach my $x (sort keys %lower) {
1723             if (! $is_utf8_locale) {
1724                 my $y = uc $x;
1725                 next unless lc $y eq $x;
1726                 print "# lower $x uc $y ",
1727                     $x =~ /$y/i ? 1 : 0, " ",
1728                     $y =~ /$x/i ? 1 : 0, "\n" if 0;
1729                 if ($x =~ $re || $y =~ $re) { # See above.
1730                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
1731                     next;
1732                 }
1733                 # With utf8 both will fail since the locale concept
1734                 # of upper/lower does not work well in Unicode.
1735                 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
1736
1737                 push @f, $x unless lc $x eq fc $x;
1738             }
1739             else {
1740                 use locale ':not_characters';
1741                 my $y = uc $x;
1742                 next unless lc $y eq $x;
1743                 print "# lower $x uc $y ",
1744                         $x =~ /$y/i ? 1 : 0, " ",
1745                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1746                 push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
1747
1748                 push @f, $x unless lc $x eq fc $x;
1749             }
1750         }
1751         report_multi_result($Locale, $locales_test_number, \@f);
1752     }
1753
1754     # [perl #109318]
1755     {
1756         my @f = ();
1757         ++$locales_test_number;
1758         $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
1759
1760         my $radix = POSIX::localeconv()->{decimal_point};
1761         my @nums = (
1762              "3.14e+9",  "3${radix}14e+9",  "3.14e-9",  "3${radix}14e-9",
1763             "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
1764         );
1765
1766         if (! $is_utf8_locale) {
1767             use locale;
1768             for my $num (@nums) {
1769                 push @f, $num
1770                     unless sprintf("%g", $num) =~ /3.+14/;
1771             }
1772         }
1773         else {
1774             use locale ':not_characters';
1775             for my $num (@nums) {
1776                 push @f, $num
1777                     unless sprintf("%g", $num) =~ /3.+14/;
1778             }
1779         }
1780
1781         report_result($Locale, $locales_test_number, @f == 0);
1782         if (@f) {
1783             print "# failed $locales_test_number locale '$Locale' numbers @f\n"
1784         }
1785     }
1786 }
1787
1788 my $final_locales_test_number = $locales_test_number;
1789
1790 # Recount the errors.
1791
1792 foreach ($first_locales_test_number..$final_locales_test_number) {
1793     if (%setlocale_failed) {
1794         print "not ";
1795     }
1796     elsif ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
1797         if (defined $not_necessarily_a_problem_test_number
1798             && $_ == $not_necessarily_a_problem_test_number)
1799         {
1800             print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
1801             print "# It usually indicates a problem in the environment,\n";
1802             print "# not in Perl itself.\n";
1803         }
1804         if ($Okay{$_} && ($_ >= $first_casing_test_number
1805                           && $_ <= $final_casing_test_number))
1806         {
1807             # Round to nearest .1%
1808             my $percent_fail = (int(.5 + (1000 * scalar(keys $Problem{$_})
1809                                           / scalar(@Locale))))
1810                                / 10;
1811             if (! $debug && $percent_fail < $acceptable_fold_failure_percentage)
1812             {
1813                 $test_names{$_} .= 'TODO';
1814                 print "# ", 100 - $percent_fail, "% of locales pass the following test, so it is likely that the failures\n";
1815                 print "# are errors in the locale definitions.  The test is marked TODO, as the\n";
1816                 print "# problem is not likely to be Perl's\n";
1817             }
1818         }
1819         print "#\n";
1820         if ($debug) {
1821             print "# The code points that had this failure are given above.  Look for lines\n";
1822             print "# that match 'failed $_'\n";
1823         }
1824         else {
1825             print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
1826             print "# Then look at that output for lines that match 'failed $_'\n";
1827         }
1828         print "not ";
1829     }
1830     print "ok $_";
1831     if (defined $test_names{$_}) {
1832         # If TODO is in the test name, make it thus
1833         my $todo = $test_names{$_} =~ s/TODO\s*//;
1834         print " $test_names{$_}";
1835         print " # TODO" if $todo;
1836     }
1837     print "\n";
1838 }
1839
1840 $test_num = $final_locales_test_number;
1841
1842 {   # perl #115808
1843     use warnings;
1844     my $warned = 0;
1845     local $SIG{__WARN__} = sub {
1846         $warned = $_[0] =~ /uninitialized/;
1847     };
1848     my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
1849     ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
1850 }
1851
1852 # Test that tainting and case changing works on utf8 strings.  These tests are
1853 # placed last to avoid disturbing the hard-coded test numbers that existed at
1854 # the time these were added above this in this file.
1855 # This also tests that locale overrides unicode_strings in the same scope for
1856 # non-utf8 strings.
1857 setlocale(&POSIX::LC_ALL, "C");
1858 {
1859     use locale;
1860     use feature 'unicode_strings';
1861
1862     foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
1863         my @list;   # List of code points to test for $function
1864
1865         # Used to calculate the changed case for ASCII characters by using the
1866         # ord, instead of using one of the functions under test.
1867         my $ascii_case_change_delta;
1868         my $above_latin1_case_change_delta; # Same for the specific ords > 255
1869                                             # that we use
1870
1871         # We test an ASCII character, which should change case and be tainted;
1872         # a Latin1 character, which shouldn't change case under this C locale,
1873         #   and is tainted.
1874         # an above-Latin1 character that when the case is changed would cross
1875         #   the 255/256 boundary, so doesn't change case and isn't tainted
1876         # (the \x{149} is one of these, but changes into 2 characters, the
1877         #   first one of which doesn't cross the boundary.
1878         # the final one in each list is an above-Latin1 character whose case
1879         #   does change, and shouldn't be tainted.  The code below uses its
1880         #   position in its list as a marker to indicate that it, unlike the
1881         #   other code points above ASCII, has a successful case change
1882         if ($function =~ /^u/) {
1883             @list = ("", "a", "\xe0", "\xff", "\x{fb00}", "\x{149}", "\x{101}");
1884             $ascii_case_change_delta = -32;
1885             $above_latin1_case_change_delta = -1;
1886         }
1887         else {
1888             @list = ("", "A", "\xC0", "\x{17F}", "\x{100}");
1889             $ascii_case_change_delta = +32;
1890             $above_latin1_case_change_delta = +1;
1891         }
1892         foreach my $is_utf8_locale (0 .. 1) {
1893             foreach my $j (0 .. $#list) {
1894                 my $char = $list[$j];
1895
1896                 for my $encoded_in_utf8 (0 .. 1) {
1897                     my $should_be;
1898                     my $changed;
1899                     if (! $is_utf8_locale) {
1900                         $should_be = ($j == $#list)
1901                             ? chr(ord($char) + $above_latin1_case_change_delta)
1902                             : (length $char == 0 || ord($char) > 127)
1903                             ? $char
1904                             : chr(ord($char) + $ascii_case_change_delta);
1905
1906                         # This monstrosity is in order to avoid using an eval,
1907                         # which might perturb the results
1908                         $changed = ($function eq "uc")
1909                                     ? uc($char)
1910                                     : ($function eq "ucfirst")
1911                                       ? ucfirst($char)
1912                                       : ($function eq "lc")
1913                                         ? lc($char)
1914                                         : ($function eq "lcfirst")
1915                                           ? lcfirst($char)
1916                                           : ($function eq "fc")
1917                                             ? fc($char)
1918                                             : die("Unexpected function \"$function\"");
1919                     }
1920                     else {
1921                         {
1922                             no locale;
1923
1924                             # For utf8-locales the case changing functions
1925                             # should work just like they do outside of locale.
1926                             # Can use eval here because not testing it when
1927                             # not in locale.
1928                             $should_be = eval "$function('$char')";
1929                             die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if  $@;
1930
1931                         }
1932                         use locale ':not_characters';
1933                         $changed = ($function eq "uc")
1934                                     ? uc($char)
1935                                     : ($function eq "ucfirst")
1936                                       ? ucfirst($char)
1937                                       : ($function eq "lc")
1938                                         ? lc($char)
1939                                         : ($function eq "lcfirst")
1940                                           ? lcfirst($char)
1941                                           : ($function eq "fc")
1942                                             ? fc($char)
1943                                             : die("Unexpected function \"$function\"");
1944                     }
1945                     ok($changed eq $should_be,
1946                         "$function(\"$char\") in C locale "
1947                         . (($is_utf8_locale)
1948                             ? "(use locale ':not_characters'"
1949                             : "(use locale")
1950                         . (($encoded_in_utf8)
1951                             ? "; encoded in utf8)"
1952                             : "; not encoded in utf8)")
1953                         . " should be \"$should_be\", got \"$changed\"");
1954
1955                     # Tainting shouldn't happen for utf8 locales, empty
1956                     # strings, or those characters above 255.
1957                     (! $is_utf8_locale && length($char) > 0 && ord($char) < 256)
1958                     ? check_taint($changed)
1959                     : check_taint_not($changed);
1960
1961                     # Use UTF-8 next time through the loop
1962                     utf8::upgrade($char);
1963                 }
1964             }
1965         }
1966     }
1967 }
1968
1969 # Give final advice.
1970
1971 my $didwarn = 0;
1972
1973 foreach ($first_locales_test_number..$final_locales_test_number) {
1974     if ($Problem{$_}) {
1975         my @f = sort keys %{ $Problem{$_} };
1976         my $f = join(" ", @f);
1977         $f =~ s/(.{50,60}) /$1\n#\t/g;
1978         print
1979             "#\n",
1980             "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
1981             "#\t", $f, "\n#\n",
1982             "# on your system may have errors because the locale test $_\n",
1983             "# \"$test_names{$_}\"\n",
1984             "# failed in ", (@f == 1 ? "that locale" : "those locales"),
1985             ".\n";
1986         print <<EOW;
1987 #
1988 # If your users are not using these locales you are safe for the moment,
1989 # but please report this failure first to perlbug\@perl.com using the
1990 # perlbug script (as described in the INSTALL file) so that the exact
1991 # details of the failures can be sorted out first and then your operating
1992 # system supplier can be alerted about these anomalies.
1993 #
1994 EOW
1995         $didwarn = 1;
1996     }
1997 }
1998
1999 # Tell which locales were okay and which were not.
2000
2001 if ($didwarn) {
2002     my (@s, @F);
2003
2004     foreach my $l (@Locale) {
2005         my $p = 0;
2006         if ($setlocale_failed{$l}) {
2007             $p++;
2008         }
2009         else {
2010             foreach my $t
2011                         ($first_locales_test_number..$final_locales_test_number)
2012             {
2013                 $p++ if $Problem{$t}{$l};
2014             }
2015         }
2016         push @s, $l if $p == 0;
2017         push @F, $l unless $p == 0;
2018     }
2019
2020     if (@s) {
2021         my $s = join(" ", @s);
2022         $s =~ s/(.{50,60}) /$1\n#\t/g;
2023
2024         warn
2025             "# The following locales\n#\n",
2026             "#\t", $s, "\n#\n",
2027             "# tested okay.\n#\n",
2028     } else {
2029         warn "# None of your locales were fully okay.\n";
2030     }
2031
2032     if (@F) {
2033         my $F = join(" ", @F);
2034         $F =~ s/(.{50,60}) /$1\n#\t/g;
2035
2036         warn
2037           "# The following locales\n#\n",
2038           "#\t", $F, "\n#\n",
2039           "# had problems.\n#\n",
2040           "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2041     } else {
2042         warn "# None of your locales were broken.\n";
2043     }
2044 }
2045
2046 print "1..$test_num\n";
2047
2048 # eof