lib/locale.t: Display :punct: characters under debug mode
[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{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
833         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
834         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
835         @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
836
837         # Sieve the uppercase and the lowercase.
838
839         for (@{$posixes{'word'}}) {
840             if (/[^\d_]/) { # skip digits and the _
841                 if (uc($_) eq $_) {
842                     $UPPER{$_} = $_;
843                 }
844                 if (lc($_) eq $_) {
845                     $lower{$_} = $_;
846                 }
847             }
848         }
849     }
850     else {
851         use locale ':not_characters';
852         @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
853         @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
854         @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
855         @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
856         @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
857         @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
858         @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
859         @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
860         @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
861         @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
862         @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
863         @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
864         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
865         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
866         @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
867         for (@{$posixes{'word'}}) {
868             if (/[^\d_]/) { # skip digits and the _
869                 if (uc($_) eq $_) {
870                     $UPPER{$_} = $_;
871                 }
872                 if (lc($_) eq $_) {
873                     $lower{$_} = $_;
874                 }
875             }
876         }
877     }
878
879     # Ordered, where possible,  in groups of "this is a subset of the next
880     # one"
881     debug "# :upper:  = ", display_characters(@{$posixes{'upper'}}), "\n";
882     debug "# :lower:  = ", display_characters(@{$posixes{'lower'}}), "\n";
883     debug "# :cased:  = ", display_characters(@{$posixes{'cased'}}), "\n";
884     debug "# :alpha:  = ", display_characters(@{$posixes{'alpha'}}), "\n";
885     debug "# :alnum:  = ", display_characters(@{$posixes{'alnum'}}), "\n";
886     debug "#  w       = ", display_characters(@{$posixes{'word'}}), "\n";
887     debug "# :graph:  = ", display_characters(@{$posixes{'graph'}}), "\n";
888     debug "# :print:  = ", display_characters(@{$posixes{'print'}}), "\n";
889     debug "#  d       = ", display_characters(@{$posixes{'digit'}}), "\n";
890     debug "# :xdigit: = ", display_characters(@{$posixes{'xdigit'}}), "\n";
891     debug "# :blank:  = ", display_characters(@{$posixes{'blank'}}), "\n";
892     debug "#  s       = ", display_characters(@{$posixes{'space'}}), "\n";
893     debug "# :punct:  = ", display_characters(@{$posixes{'punct'}}), "\n";
894     debug "# :cntrl:  = ", display_characters(@{$posixes{'cntrl'}}), "\n";
895     debug "# :ascii:  = ", display_characters(@{$posixes{'ascii'}}), "\n";
896
897     foreach (keys %UPPER) {
898
899         $BoThCaSe{$_}++ if exists $lower{$_};
900     }
901     foreach (keys %lower) {
902         $BoThCaSe{$_}++ if exists $UPPER{$_};
903     }
904     foreach (keys %BoThCaSe) {
905         delete $UPPER{$_};
906         delete $lower{$_};
907     }
908
909     debug "# UPPER    = ", display_characters(keys %UPPER), "\n";
910     debug "# lower    = ", display_characters(keys %lower), "\n";
911     debug "# BoThCaSe = ", display_characters(keys %BoThCaSe), "\n";
912
913     my @failures;
914     my @fold_failures;
915     foreach my $x (sort keys %UPPER) {
916         my $ok;
917         my $fold_ok;
918         if ($is_utf8_locale) {
919             use locale ':not_characters';
920             $ok = $x =~ /[[:upper:]]/;
921             $fold_ok = $x =~ /[[:lower:]]/i;
922         }
923         else {
924             use locale;
925             $ok = $x =~ /[[:upper:]]/;
926             $fold_ok = $x =~ /[[:lower:]]/i;
927         }
928         push @failures, $x unless $ok;
929         push @fold_failures, $x unless $fold_ok;
930     }
931     $locales_test_number++;
932     $first_casing_test_number = $locales_test_number;
933     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
934     report_multi_result($Locale, $locales_test_number, \@failures);
935
936     $locales_test_number++;
937
938     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
939     report_multi_result($Locale, $locales_test_number, \@fold_failures);
940
941     undef @failures;
942     undef @fold_failures;
943
944     foreach my $x (sort keys %lower) {
945         my $ok;
946         my $fold_ok;
947         if ($is_utf8_locale) {
948             use locale ':not_characters';
949             $ok = $x =~ /[[:lower:]]/;
950             $fold_ok = $x =~ /[[:upper:]]/i;
951         }
952         else {
953             use locale;
954             $ok = $x =~ /[[:lower:]]/;
955             $fold_ok = $x =~ /[[:upper:]]/i;
956         }
957         push @failures, $x unless $ok;
958         push @fold_failures, $x unless $fold_ok;
959     }
960
961     $locales_test_number++;
962     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
963     report_multi_result($Locale, $locales_test_number, \@failures);
964
965     $locales_test_number++;
966     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
967     report_multi_result($Locale, $locales_test_number, \@fold_failures);
968
969     {   # Find the alphabetic characters that are not considered alphabetics
970         # in the default (C) locale.
971
972         no locale;
973
974         @Added_alpha = ();
975         for (keys %UPPER, keys %lower, keys %BoThCaSe) {
976             push(@Added_alpha, $_) if (/\W/);
977         }
978     }
979
980     @Added_alpha = sort @Added_alpha;
981
982     debug "# Added_alpha = ", display_characters(@Added_alpha), "\n";
983
984     # Cross-check the whole 8-bit character set.
985
986     ++$locales_test_number;
987     my @f;
988     $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
989     for (map { chr } 0..255) {
990         if ($is_utf8_locale) {
991             use locale ':not_characters';
992             push @f, $_ unless /[[:word:]]/ == /\w/;
993         }
994         else {
995             push @f, $_ unless /[[:word:]]/ == /\w/;
996         }
997     }
998     report_multi_result($Locale, $locales_test_number, \@f);
999
1000     ++$locales_test_number;
1001     undef @f;
1002     $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1003     for (map { chr } 0..255) {
1004         if ($is_utf8_locale) {
1005             use locale ':not_characters';
1006             push @f, $_ unless /[[:digit:]]/ == /\d/;
1007         }
1008         else {
1009             push @f, $_ unless /[[:digit:]]/ == /\d/;
1010         }
1011     }
1012     report_multi_result($Locale, $locales_test_number, \@f);
1013
1014     ++$locales_test_number;
1015     undef @f;
1016     $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1017     for (map { chr } 0..255) {
1018         if ($is_utf8_locale) {
1019             use locale ':not_characters';
1020             push @f, $_ unless /[[:space:]]/ == /\s/;
1021         }
1022         else {
1023             push @f, $_ unless /[[:space:]]/ == /\s/;
1024         }
1025     }
1026     report_multi_result($Locale, $locales_test_number, \@f);
1027
1028     ++$locales_test_number;
1029     undef @f;
1030     $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1031     for (map { chr } 0..255) {
1032         if ($is_utf8_locale) {
1033             use locale ':not_characters';
1034             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1035                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1036                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1037                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1038                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1039                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1040                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1041                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1042                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1043                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1044                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1045                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1046                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1047
1048                     # effectively is what [:cased:] would be if it existed.
1049                     (/[[:upper:]]/i xor /[[:^upper:]]/i);
1050         }
1051         else {
1052             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1053                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1054                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1055                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1056                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1057                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1058                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1059                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1060                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1061                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1062                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1063                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1064                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1065                     (/[[:upper:]]/i xor /[[:^upper:]]/i);
1066         }
1067     }
1068     report_multi_result($Locale, $locales_test_number, \@f);
1069
1070     # The rules for the relationships are given in:
1071     # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1072
1073     ++$locales_test_number;
1074     undef @f;
1075     $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1076     for (map { chr } 0..255) {
1077         if ($is_utf8_locale) {
1078             use locale ':not_characters';
1079             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1080         }
1081         else {
1082             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1083         }
1084     }
1085     report_multi_result($Locale, $locales_test_number, \@f);
1086
1087     ++$locales_test_number;
1088     undef @f;
1089     $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1090     for (map { chr } 0..255) {
1091         if ($is_utf8_locale) {
1092             use locale ':not_characters';
1093             push @f, $_  if /[[:upper:]]/ and ! /[[:alpha:]]/;
1094         }
1095         else {
1096             push @f, $_ if /[[:upper:]]/  and ! /[[:alpha:]]/;
1097         }
1098     }
1099     report_multi_result($Locale, $locales_test_number, \@f);
1100
1101     ++$locales_test_number;
1102     undef @f;
1103     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1104     for (map { chr } 0..255) {
1105         if ($is_utf8_locale) {
1106             use locale ':not_characters';
1107             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1108         }
1109         else {
1110             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1111         }
1112     }
1113     report_multi_result($Locale, $locales_test_number, \@f);
1114
1115     ++$locales_test_number;
1116     undef @f;
1117     $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1118     for (map { chr } 0..255) {
1119         if ($is_utf8_locale) {
1120             use locale ':not_characters';
1121             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1122         }
1123         else {
1124             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1125         }
1126     }
1127     report_multi_result($Locale, $locales_test_number, \@f);
1128
1129     ++$locales_test_number;
1130     undef @f;
1131     $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1132     for (map { chr } 0..255) {
1133         if ($is_utf8_locale) {
1134             use locale ':not_characters';
1135             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1136         }
1137         else {
1138             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1139         }
1140     }
1141     report_multi_result($Locale, $locales_test_number, \@f);
1142
1143     ++$locales_test_number;
1144     undef @f;
1145     $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1146     report_result($Locale, $locales_test_number, @{$posixes{'digit'}} == 10 || @{$posixes{'digit'}} == 20);
1147
1148     ++$locales_test_number;
1149     undef @f;
1150     $test_names{$locales_test_number} = 'Verify that [:digit:] (if is 10 code points) is a subset of [:xdigit:]';
1151     if (@{$posixes{'digit'}} == 10) {
1152         for (map { chr } 0..255) {
1153             if ($is_utf8_locale) {
1154                 use locale ':not_characters';
1155                 push @f, $_ if /[[:digit:]]/  and ! /[[:xdigit:]]/;
1156             }
1157             else {
1158                 push @f, $_ if /[[:digit:]]/  and ! /[[:xdigit:]]/;
1159             }
1160         }
1161     }
1162     report_multi_result($Locale, $locales_test_number, \@f);
1163
1164     ++$locales_test_number;
1165     undef @f;
1166     $test_names{$locales_test_number} = 'Verify that [:alnum:] is a subset of [:graph:]';
1167     for (map { chr } 0..255) {
1168         if ($is_utf8_locale) {
1169             use locale ':not_characters';
1170             push @f, $_ if /[[:alnum:]]/  and ! /[[:graph:]]/;
1171         }
1172         else {
1173             push @f, $_ if /[[:alnum:]]/  and ! /[[:graph:]]/;
1174         }
1175     }
1176     report_multi_result($Locale, $locales_test_number, \@f);
1177
1178     # Note that xdigit doesn't have to be a subset of alnum
1179
1180     ++$locales_test_number;
1181     undef @f;
1182     $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1183     for (map { chr } 0..255) {
1184         if ($is_utf8_locale) {
1185             use locale ':not_characters';
1186             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1187         }
1188         else {
1189             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1190         }
1191     }
1192     report_multi_result($Locale, $locales_test_number, \@f);
1193
1194     ++$locales_test_number;
1195     undef @f;
1196     $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1197     for (map { chr } 0..255) {
1198         if ($is_utf8_locale) {
1199             use locale ':not_characters';
1200             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1201         }
1202         else {
1203             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1204         }
1205     }
1206     report_multi_result($Locale, $locales_test_number, \@f);
1207
1208     ++$locales_test_number;
1209     undef @f;
1210     $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1211     for (map { chr } 0..255) {
1212         if ($is_utf8_locale) {
1213             use locale ':not_characters';
1214             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1215         }
1216         else {
1217             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1218         }
1219     }
1220     report_multi_result($Locale, $locales_test_number, \@f);
1221
1222     ++$locales_test_number;
1223     undef @f;
1224     $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1225     for (map { chr } 0..255) {
1226         if ($is_utf8_locale) {
1227             use locale ':not_characters';
1228             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1229         }
1230         else {
1231             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1232         }
1233     }
1234     report_multi_result($Locale, $locales_test_number, \@f);
1235
1236     ++$locales_test_number;
1237     undef @f;
1238     $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1239     for (map { chr } 0..255) {
1240         if ($is_utf8_locale) {
1241             use locale ':not_characters';
1242             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1243         }
1244         else {
1245             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1246         }
1247     }
1248     report_multi_result($Locale, $locales_test_number, \@f);
1249
1250     ++$locales_test_number;
1251     undef @f;
1252     $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1253     for (map { chr } 0..255) {
1254         if ($is_utf8_locale) {
1255             use locale ':not_characters';
1256             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1257         }
1258         else {
1259             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1260         }
1261     }
1262     report_multi_result($Locale, $locales_test_number, \@f);
1263
1264     ++$locales_test_number;
1265     undef @f;
1266     $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1267     for (map { chr } 0..255) {
1268         if ($is_utf8_locale) {
1269             use locale ':not_characters';
1270             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1271         }
1272         else {
1273             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1274         }
1275     }
1276     report_multi_result($Locale, $locales_test_number, \@f);
1277
1278     ++$locales_test_number;
1279     undef @f;
1280     $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1281     for (map { chr } 0..255) {
1282         if ($is_utf8_locale) {
1283             use locale ':not_characters';
1284             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1285         }
1286         else {
1287             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1288         }
1289     }
1290     report_multi_result($Locale, $locales_test_number, \@f);
1291
1292     $final_casing_test_number = $locales_test_number;
1293
1294     # Test for read-only scalars' locale vs non-locale comparisons.
1295
1296     {
1297         no locale;
1298         my $ok;
1299         $a = "qwerty";
1300         if ($is_utf8_locale) {
1301             use locale ':not_characters';
1302             $ok = ($a cmp "qwerty") == 0;
1303         }
1304         else {
1305             use locale;
1306             $ok = ($a cmp "qwerty") == 0;
1307         }
1308         report_result($Locale, ++$locales_test_number, $ok);
1309         $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1310     }
1311
1312     {
1313         my ($from, $to, $lesser, $greater,
1314             @test, %test, $test, $yes, $no, $sign);
1315
1316         ++$locales_test_number;
1317         $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1318         $not_necessarily_a_problem_test_number = $locales_test_number;
1319         for (0..9) {
1320             # Select a slice.
1321             $from = int(($_*@{$posixes{'word'}})/10);
1322             $to = $from + int(@{$posixes{'word'}}/10);
1323             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1324             $lesser  = join('', @{$posixes{'word'}}[$from..$to]);
1325             # Select a slice one character on.
1326             $from++; $to++;
1327             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1328             $greater = join('', @{$posixes{'word'}}[$from..$to]);
1329             if ($is_utf8_locale) {
1330                 use locale ':not_characters';
1331                 ($yes, $no, $sign) = ($lesser lt $greater
1332                                     ? ("    ", "not ", 1)
1333                                     : ("not ", "    ", -1));
1334             }
1335             else {
1336                 use locale;
1337                 ($yes, $no, $sign) = ($lesser lt $greater
1338                                     ? ("    ", "not ", 1)
1339                                     : ("not ", "    ", -1));
1340             }
1341             # all these tests should FAIL (return 0).  Exact lt or gt cannot
1342             # be tested because in some locales, say, eacute and E may test
1343             # equal.
1344             @test =
1345                 (
1346                     $no.'    ($lesser  le $greater)',  # 1
1347                     'not      ($lesser  ne $greater)', # 2
1348                     '         ($lesser  eq $greater)', # 3
1349                     $yes.'    ($lesser  ge $greater)', # 4
1350                     $yes.'    ($lesser  ge $greater)', # 5
1351                     $yes.'    ($greater le $lesser )', # 7
1352                     'not      ($greater ne $lesser )', # 8
1353                     '         ($greater eq $lesser )', # 9
1354                     $no.'     ($greater ge $lesser )', # 10
1355                     'not (($lesser cmp $greater) == -($sign))' # 11
1356                     );
1357             @test{@test} = 0 x @test;
1358             $test = 0;
1359             for my $ti (@test) {
1360                 if ($is_utf8_locale) {
1361                     use locale ':not_characters';
1362                     $test{$ti} = eval $ti;
1363                 }
1364                 else {
1365                     # Already in 'use locale';
1366                     $test{$ti} = eval $ti;
1367                 }
1368                 $test ||= $test{$ti}
1369             }
1370             report_result($Locale, $locales_test_number, $test == 0);
1371             if ($test) {
1372                 debug "# lesser  = '$lesser'\n";
1373                 debug "# greater = '$greater'\n";
1374                 debug "# lesser cmp greater = ",
1375                         $lesser cmp $greater, "\n";
1376                 debug "# greater cmp lesser = ",
1377                         $greater cmp $lesser, "\n";
1378                 debug "# (greater) from = $from, to = $to\n";
1379                 for my $ti (@test) {
1380                     debugf("# %-40s %-4s", $ti,
1381                             $test{$ti} ? 'FAIL' : 'ok');
1382                     if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1383                         debugf("(%s == %4d)", $1, eval $1);
1384                     }
1385                     debug "\n#";
1386                 }
1387
1388                 last;
1389             }
1390         }
1391     }
1392
1393     my $ok1;
1394     my $ok2;
1395     my $ok3;
1396     my $ok4;
1397     my $ok5;
1398     my $ok6;
1399     my $ok7;
1400     my $ok8;
1401     my $ok9;
1402     my $ok10;
1403     my $ok11;
1404     my $ok12;
1405     my $ok13;
1406     my $ok14;
1407     my $ok15;
1408     my $ok16;
1409
1410     my $c;
1411     my $d;
1412     my $e;
1413     my $f;
1414     my $g;
1415
1416     if (! $is_utf8_locale) {
1417         use locale;
1418
1419         my ($x, $y) = (1.23, 1.23);
1420
1421         $a = "$x";
1422         printf ''; # printf used to reset locale to "C"
1423         $b = "$y";
1424         $ok1 = $a eq $b;
1425
1426         $c = "$x";
1427         my $z = sprintf ''; # sprintf used to reset locale to "C"
1428         $d = "$y";
1429         $ok2 = $c eq $d;
1430         {
1431
1432             use warnings;
1433             my $w = 0;
1434             local $SIG{__WARN__} =
1435                 sub {
1436                     print "# @_\n";
1437                     $w++;
1438                 };
1439
1440             # The == (among other ops) used to warn for locales
1441             # that had something else than "." as the radix character.
1442
1443             $ok3 = $c == 1.23;
1444             $ok4 = $c == $x;
1445             $ok5 = $c == $d;
1446             {
1447                 no locale;
1448
1449                 $e = "$x";
1450
1451                 $ok6 = $e == 1.23;
1452                 $ok7 = $e == $x;
1453                 $ok8 = $e == $c;
1454             }
1455
1456             $f = "1.23";
1457             $g = 2.34;
1458
1459             $ok9 = $f == 1.23;
1460             $ok10 = $f == $x;
1461             $ok11 = $f == $c;
1462             $ok12 = abs(($f + $g) - 3.57) < 0.01;
1463             $ok13 = $w == 0;
1464             $ok14 = $ok15 = $ok16 = 1;  # Skip for non-utf8 locales
1465         }
1466     }
1467     else {
1468         use locale ':not_characters';
1469
1470         my ($x, $y) = (1.23, 1.23);
1471         $a = "$x";
1472         printf ''; # printf used to reset locale to "C"
1473         $b = "$y";
1474         $ok1 = $a eq $b;
1475
1476         $c = "$x";
1477         my $z = sprintf ''; # sprintf used to reset locale to "C"
1478         $d = "$y";
1479         $ok2 = $c eq $d;
1480         {
1481             use warnings;
1482             my $w = 0;
1483             local $SIG{__WARN__} =
1484                 sub {
1485                     print "# @_\n";
1486                     $w++;
1487                 };
1488             $ok3 = $c == 1.23;
1489             $ok4 = $c == $x;
1490             $ok5 = $c == $d;
1491             {
1492                 no locale;
1493                 $e = "$x";
1494
1495                 $ok6 = $e == 1.23;
1496                 $ok7 = $e == $x;
1497                 $ok8 = $e == $c;
1498             }
1499
1500             $f = "1.23";
1501             $g = 2.34;
1502
1503             $ok9 = $f == 1.23;
1504             $ok10 = $f == $x;
1505             $ok11 = $f == $c;
1506             $ok12 = abs(($f + $g) - 3.57) < 0.01;
1507             $ok13 = $w == 0;
1508
1509             # Look for non-ASCII error messages, and verify that the first
1510             # such is in UTF-8 (the others almost certainly will be like the
1511             # first).
1512             $ok14 = 1;
1513             foreach my $err (keys %!) {
1514                 use Errno;
1515                 $! = eval "&Errno::$err";   # Convert to strerror() output
1516                 my $strerror = "$!";
1517                 if ("$strerror" =~ /\P{ASCII}/) {
1518                     my $utf8_strerror = $strerror;
1519                     utf8::upgrade($utf8_strerror);
1520
1521                     # If $! was already in UTF-8, the upgrade was a no-op;
1522                     # otherwise they will be different byte strings.
1523                     use bytes;
1524                     $ok14 = $utf8_strerror eq $strerror;
1525                     last;
1526                 }
1527             }
1528
1529             # Similarly, we verify that a non-ASCII radix is in UTF-8.  This
1530             # also catches if there is a disparity between sprintf and
1531             # stringification.
1532
1533             my $string_g = "$g";
1534
1535             my $utf8_string_g = "$g";
1536             utf8::upgrade($utf8_string_g);
1537
1538             my $utf8_sprintf_g = sprintf("%g", $g);
1539             utf8::upgrade($utf8_sprintf_g);
1540             use bytes;
1541             $ok15 = $utf8_string_g eq $string_g;
1542             $ok16 = $utf8_sprintf_g eq $string_g;
1543         }
1544     }
1545
1546     report_result($Locale, ++$locales_test_number, $ok1);
1547     $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
1548     my $first_a_test = $locales_test_number;
1549
1550     debug "# $first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
1551
1552     report_result($Locale, ++$locales_test_number, $ok2);
1553     $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
1554
1555     my $first_c_test = $locales_test_number;
1556
1557     report_result($Locale, ++$locales_test_number, $ok3);
1558     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
1559
1560     report_result($Locale, ++$locales_test_number, $ok4);
1561     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
1562
1563     report_result($Locale, ++$locales_test_number, $ok5);
1564     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
1565
1566     debug "# $first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
1567
1568     report_result($Locale, ++$locales_test_number, $ok6);
1569     $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
1570     my $first_e_test = $locales_test_number;
1571
1572     report_result($Locale, ++$locales_test_number, $ok7);
1573     $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
1574
1575     report_result($Locale, ++$locales_test_number, $ok8);
1576     $test_names{$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
1577
1578     debug "# $first_e_test..$locales_test_number: \$e = $e, no locale\n";
1579
1580     report_result($Locale, ++$locales_test_number, $ok9);
1581     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
1582     my $first_f_test = $locales_test_number;
1583
1584     report_result($Locale, ++$locales_test_number, $ok10);
1585     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
1586
1587     report_result($Locale, ++$locales_test_number, $ok11);
1588     $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';
1589
1590     report_result($Locale, ++$locales_test_number, $ok12);
1591     $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';
1592
1593     report_result($Locale, ++$locales_test_number, $ok13);
1594     $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
1595
1596     report_result($Locale, ++$locales_test_number, $ok14);
1597     $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
1598
1599     report_result($Locale, ++$locales_test_number, $ok15);
1600     $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
1601
1602     report_result($Locale, ++$locales_test_number, $ok16);
1603     $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
1604
1605     debug "# $first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
1606
1607     # Does taking lc separately differ from taking
1608     # the lc "in-line"?  (This was the bug 19990704.002, change #3568.)
1609     # The bug was in the caching of the 'o'-magic.
1610     if (! $is_utf8_locale) {
1611         use locale;
1612
1613         sub lcA {
1614             my $lc0 = lc $_[0];
1615             my $lc1 = lc $_[1];
1616             return $lc0 cmp $lc1;
1617         }
1618
1619         sub lcB {
1620             return lc($_[0]) cmp lc($_[1]);
1621         }
1622
1623         my $x = "ab";
1624         my $y = "aa";
1625         my $z = "AB";
1626
1627         report_result($Locale, ++$locales_test_number,
1628                     lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
1629                     lcA($x, $z) == 0 && lcB($x, $z) == 0);
1630     }
1631     else {
1632         use locale ':not_characters';
1633
1634         sub lcC {
1635             my $lc0 = lc $_[0];
1636             my $lc1 = lc $_[1];
1637             return $lc0 cmp $lc1;
1638         }
1639
1640         sub lcD {
1641             return lc($_[0]) cmp lc($_[1]);
1642         }
1643
1644         my $x = "ab";
1645         my $y = "aa";
1646         my $z = "AB";
1647
1648         report_result($Locale, ++$locales_test_number,
1649                     lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
1650                     lcC($x, $z) == 0 && lcD($x, $z) == 0);
1651     }
1652     $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
1653
1654     # Does lc of an UPPER (if different from the UPPER) match
1655     # case-insensitively the UPPER, and does the UPPER match
1656     # case-insensitively the lc of the UPPER.  And vice versa.
1657     {
1658         use locale;
1659         no utf8;
1660         my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
1661
1662         my @f = ();
1663         ++$locales_test_number;
1664         $test_names{$locales_test_number} = 'Verify case insensitive matching works';
1665         foreach my $x (sort keys %UPPER) {
1666             if (! $is_utf8_locale) {
1667                 my $y = lc $x;
1668                 next unless uc $y eq $x;
1669                 print "# UPPER $x lc $y ",
1670                         $x =~ /$y/i ? 1 : 0, " ",
1671                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1672                 #
1673                 # If $x and $y contain regular expression characters
1674                 # AND THEY lowercase (/i) to regular expression characters,
1675                 # regcomp() will be mightily confused.  No, the \Q doesn't
1676                 # help here (maybe regex engine internal lowercasing
1677                 # is done after the \Q?)  An example of this happening is
1678                 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
1679                 # the chr(173) (the "[") is the lowercase of the chr(235).
1680                 #
1681                 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
1682                 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
1683                 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
1684                 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
1685                 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
1686                 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
1687                 #
1688                 # Similar things can happen even under (bastardised)
1689                 # non-EBCDIC locales: in many European countries before the
1690                 # advent of ISO 8859-x nationally customised versions of
1691                 # ISO 646 were devised, reusing certain punctuation
1692                 # characters for modified characters needed by the
1693                 # country/language.  For example, the "|" might have
1694                 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
1695                 #
1696                 if ($x =~ $re || $y =~ $re) {
1697                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
1698                     next;
1699                 }
1700                 # With utf8 both will fail since the locale concept
1701                 # of upper/lower does not work well in Unicode.
1702                 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
1703
1704                 # fc is not a locale concept, so Perl uses lc for it.
1705                 push @f, $x unless lc $x eq fc $x;
1706             }
1707             else {
1708                 use locale ':not_characters';
1709                 my $y = lc $x;
1710                 next unless uc $y eq $x;
1711                 print "# UPPER $x lc $y ",
1712                         $x =~ /$y/i ? 1 : 0, " ",
1713                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1714
1715                 # Here, we can fully test things, unlike plain 'use locale',
1716                 # because this form does work well with Unicode
1717                 push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
1718
1719                 # The places where Unicode's lc is different from fc are
1720                 # skipped here by virtue of the 'next unless uc...' line above
1721                 push @f, $x unless lc $x eq fc $x;
1722             }
1723         }
1724
1725         foreach my $x (sort keys %lower) {
1726             if (! $is_utf8_locale) {
1727                 my $y = uc $x;
1728                 next unless lc $y eq $x;
1729                 print "# lower $x uc $y ",
1730                     $x =~ /$y/i ? 1 : 0, " ",
1731                     $y =~ /$x/i ? 1 : 0, "\n" if 0;
1732                 if ($x =~ $re || $y =~ $re) { # See above.
1733                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
1734                     next;
1735                 }
1736                 # With utf8 both will fail since the locale concept
1737                 # of upper/lower does not work well in Unicode.
1738                 push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
1739
1740                 push @f, $x unless lc $x eq fc $x;
1741             }
1742             else {
1743                 use locale ':not_characters';
1744                 my $y = uc $x;
1745                 next unless lc $y eq $x;
1746                 print "# lower $x uc $y ",
1747                         $x =~ /$y/i ? 1 : 0, " ",
1748                         $y =~ /$x/i ? 1 : 0, "\n" if 0;
1749                 push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
1750
1751                 push @f, $x unless lc $x eq fc $x;
1752             }
1753         }
1754         report_multi_result($Locale, $locales_test_number, \@f);
1755     }
1756
1757     # [perl #109318]
1758     {
1759         my @f = ();
1760         ++$locales_test_number;
1761         $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
1762
1763         my $radix = POSIX::localeconv()->{decimal_point};
1764         my @nums = (
1765              "3.14e+9",  "3${radix}14e+9",  "3.14e-9",  "3${radix}14e-9",
1766             "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
1767         );
1768
1769         if (! $is_utf8_locale) {
1770             use locale;
1771             for my $num (@nums) {
1772                 push @f, $num
1773                     unless sprintf("%g", $num) =~ /3.+14/;
1774             }
1775         }
1776         else {
1777             use locale ':not_characters';
1778             for my $num (@nums) {
1779                 push @f, $num
1780                     unless sprintf("%g", $num) =~ /3.+14/;
1781             }
1782         }
1783
1784         report_result($Locale, $locales_test_number, @f == 0);
1785         if (@f) {
1786             print "# failed $locales_test_number locale '$Locale' numbers @f\n"
1787         }
1788     }
1789 }
1790
1791 my $final_locales_test_number = $locales_test_number;
1792
1793 # Recount the errors.
1794
1795 foreach ($first_locales_test_number..$final_locales_test_number) {
1796     if (%setlocale_failed) {
1797         print "not ";
1798     }
1799     elsif ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
1800         if (defined $not_necessarily_a_problem_test_number
1801             && $_ == $not_necessarily_a_problem_test_number)
1802         {
1803             print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
1804             print "# It usually indicates a problem in the environment,\n";
1805             print "# not in Perl itself.\n";
1806         }
1807         if ($Okay{$_} && ($_ >= $first_casing_test_number
1808                           && $_ <= $final_casing_test_number))
1809         {
1810             # Round to nearest .1%
1811             my $percent_fail = (int(.5 + (1000 * scalar(keys $Problem{$_})
1812                                           / scalar(@Locale))))
1813                                / 10;
1814             if (! $debug && $percent_fail < $acceptable_fold_failure_percentage)
1815             {
1816                 $test_names{$_} .= 'TODO';
1817                 print "# ", 100 - $percent_fail, "% of locales pass the following test, so it is likely that the failures\n";
1818                 print "# are errors in the locale definitions.  The test is marked TODO, as the\n";
1819                 print "# problem is not likely to be Perl's\n";
1820             }
1821         }
1822         print "#\n";
1823         if ($debug) {
1824             print "# The code points that had this failure are given above.  Look for lines\n";
1825             print "# that match 'failed $_'\n";
1826         }
1827         else {
1828             print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
1829             print "# Then look at that output for lines that match 'failed $_'\n";
1830         }
1831         print "not ";
1832     }
1833     print "ok $_";
1834     if (defined $test_names{$_}) {
1835         # If TODO is in the test name, make it thus
1836         my $todo = $test_names{$_} =~ s/TODO\s*//;
1837         print " $test_names{$_}";
1838         print " # TODO" if $todo;
1839     }
1840     print "\n";
1841 }
1842
1843 $test_num = $final_locales_test_number;
1844
1845 {   # perl #115808
1846     use warnings;
1847     my $warned = 0;
1848     local $SIG{__WARN__} = sub {
1849         $warned = $_[0] =~ /uninitialized/;
1850     };
1851     my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
1852     ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
1853 }
1854
1855 # Test that tainting and case changing works on utf8 strings.  These tests are
1856 # placed last to avoid disturbing the hard-coded test numbers that existed at
1857 # the time these were added above this in this file.
1858 # This also tests that locale overrides unicode_strings in the same scope for
1859 # non-utf8 strings.
1860 setlocale(&POSIX::LC_ALL, "C");
1861 {
1862     use locale;
1863     use feature 'unicode_strings';
1864
1865     foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
1866         my @list;   # List of code points to test for $function
1867
1868         # Used to calculate the changed case for ASCII characters by using the
1869         # ord, instead of using one of the functions under test.
1870         my $ascii_case_change_delta;
1871         my $above_latin1_case_change_delta; # Same for the specific ords > 255
1872                                             # that we use
1873
1874         # We test an ASCII character, which should change case and be tainted;
1875         # a Latin1 character, which shouldn't change case under this C locale,
1876         #   and is tainted.
1877         # an above-Latin1 character that when the case is changed would cross
1878         #   the 255/256 boundary, so doesn't change case and isn't tainted
1879         # (the \x{149} is one of these, but changes into 2 characters, the
1880         #   first one of which doesn't cross the boundary.
1881         # the final one in each list is an above-Latin1 character whose case
1882         #   does change, and shouldn't be tainted.  The code below uses its
1883         #   position in its list as a marker to indicate that it, unlike the
1884         #   other code points above ASCII, has a successful case change
1885         if ($function =~ /^u/) {
1886             @list = ("", "a", "\xe0", "\xff", "\x{fb00}", "\x{149}", "\x{101}");
1887             $ascii_case_change_delta = -32;
1888             $above_latin1_case_change_delta = -1;
1889         }
1890         else {
1891             @list = ("", "A", "\xC0", "\x{17F}", "\x{100}");
1892             $ascii_case_change_delta = +32;
1893             $above_latin1_case_change_delta = +1;
1894         }
1895         foreach my $is_utf8_locale (0 .. 1) {
1896             foreach my $j (0 .. $#list) {
1897                 my $char = $list[$j];
1898
1899                 for my $encoded_in_utf8 (0 .. 1) {
1900                     my $should_be;
1901                     my $changed;
1902                     if (! $is_utf8_locale) {
1903                         $should_be = ($j == $#list)
1904                             ? chr(ord($char) + $above_latin1_case_change_delta)
1905                             : (length $char == 0 || ord($char) > 127)
1906                             ? $char
1907                             : chr(ord($char) + $ascii_case_change_delta);
1908
1909                         # This monstrosity is in order to avoid using an eval,
1910                         # which might perturb the results
1911                         $changed = ($function eq "uc")
1912                                     ? uc($char)
1913                                     : ($function eq "ucfirst")
1914                                       ? ucfirst($char)
1915                                       : ($function eq "lc")
1916                                         ? lc($char)
1917                                         : ($function eq "lcfirst")
1918                                           ? lcfirst($char)
1919                                           : ($function eq "fc")
1920                                             ? fc($char)
1921                                             : die("Unexpected function \"$function\"");
1922                     }
1923                     else {
1924                         {
1925                             no locale;
1926
1927                             # For utf8-locales the case changing functions
1928                             # should work just like they do outside of locale.
1929                             # Can use eval here because not testing it when
1930                             # not in locale.
1931                             $should_be = eval "$function('$char')";
1932                             die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if  $@;
1933
1934                         }
1935                         use locale ':not_characters';
1936                         $changed = ($function eq "uc")
1937                                     ? uc($char)
1938                                     : ($function eq "ucfirst")
1939                                       ? ucfirst($char)
1940                                       : ($function eq "lc")
1941                                         ? lc($char)
1942                                         : ($function eq "lcfirst")
1943                                           ? lcfirst($char)
1944                                           : ($function eq "fc")
1945                                             ? fc($char)
1946                                             : die("Unexpected function \"$function\"");
1947                     }
1948                     ok($changed eq $should_be,
1949                         "$function(\"$char\") in C locale "
1950                         . (($is_utf8_locale)
1951                             ? "(use locale ':not_characters'"
1952                             : "(use locale")
1953                         . (($encoded_in_utf8)
1954                             ? "; encoded in utf8)"
1955                             : "; not encoded in utf8)")
1956                         . " should be \"$should_be\", got \"$changed\"");
1957
1958                     # Tainting shouldn't happen for utf8 locales, empty
1959                     # strings, or those characters above 255.
1960                     (! $is_utf8_locale && length($char) > 0 && ord($char) < 256)
1961                     ? check_taint($changed)
1962                     : check_taint_not($changed);
1963
1964                     # Use UTF-8 next time through the loop
1965                     utf8::upgrade($char);
1966                 }
1967             }
1968         }
1969     }
1970 }
1971
1972 # Give final advice.
1973
1974 my $didwarn = 0;
1975
1976 foreach ($first_locales_test_number..$final_locales_test_number) {
1977     if ($Problem{$_}) {
1978         my @f = sort keys %{ $Problem{$_} };
1979         my $f = join(" ", @f);
1980         $f =~ s/(.{50,60}) /$1\n#\t/g;
1981         print
1982             "#\n",
1983             "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
1984             "#\t", $f, "\n#\n",
1985             "# on your system may have errors because the locale test $_\n",
1986             "# \"$test_names{$_}\"\n",
1987             "# failed in ", (@f == 1 ? "that locale" : "those locales"),
1988             ".\n";
1989         print <<EOW;
1990 #
1991 # If your users are not using these locales you are safe for the moment,
1992 # but please report this failure first to perlbug\@perl.com using the
1993 # perlbug script (as described in the INSTALL file) so that the exact
1994 # details of the failures can be sorted out first and then your operating
1995 # system supplier can be alerted about these anomalies.
1996 #
1997 EOW
1998         $didwarn = 1;
1999     }
2000 }
2001
2002 # Tell which locales were okay and which were not.
2003
2004 if ($didwarn) {
2005     my (@s, @F);
2006
2007     foreach my $l (@Locale) {
2008         my $p = 0;
2009         if ($setlocale_failed{$l}) {
2010             $p++;
2011         }
2012         else {
2013             foreach my $t
2014                         ($first_locales_test_number..$final_locales_test_number)
2015             {
2016                 $p++ if $Problem{$t}{$l};
2017             }
2018         }
2019         push @s, $l if $p == 0;
2020         push @F, $l unless $p == 0;
2021     }
2022
2023     if (@s) {
2024         my $s = join(" ", @s);
2025         $s =~ s/(.{50,60}) /$1\n#\t/g;
2026
2027         warn
2028             "# The following locales\n#\n",
2029             "#\t", $s, "\n#\n",
2030             "# tested okay.\n#\n",
2031     } else {
2032         warn "# None of your locales were fully okay.\n";
2033     }
2034
2035     if (@F) {
2036         my $F = join(" ", @F);
2037         $F =~ s/(.{50,60}) /$1\n#\t/g;
2038
2039         warn
2040           "# The following locales\n#\n",
2041           "#\t", $F, "\n#\n",
2042           "# had problems.\n#\n",
2043           "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2044     } else {
2045         warn "# None of your locales were broken.\n";
2046     }
2047 }
2048
2049 print "1..$test_num\n";
2050
2051 # eof