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