Bump Perl version from 5.27.2 to 5.27.3
[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 my $is_ebcdic = ord("A") == 193;
11
12 no warnings 'locale';  # We test even weird locales; and do some scary things
13                        # in ok locales
14
15 binmode STDOUT, ':utf8';
16 binmode STDERR, ':utf8';
17
18 BEGIN {
19     chdir 't' if -d 't';
20     @INC = '../lib';
21     unshift @INC, '.';
22     require './loc_tools.pl';
23     unless (locales_enabled('LC_CTYPE')) {
24         print "1..0\n";
25         exit;
26     }
27     $| = 1;
28     require Config; import Config;
29 }
30
31 use strict;
32 use feature 'fc';
33
34 # =1 adds debugging output; =2 increases the verbosity somewhat
35 our $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
36
37 # Certain tests have been shown to be problematical for a few locales.  Don't
38 # fail them unless at least this percentage of the tested locales fail.
39 # On AIX machines, many locales call a no-break space a graphic.
40 # (There aren't 1000 locales currently in existence, so 99.9 works)
41 # EBCDIC os390 has more locales fail than normal, because it has locales that
42 # move various critical characters like '['.
43 my $acceptable_failure_percentage = ($^O =~ / ^ ( AIX ) $ /ix)
44                                      ? 99.9
45                                      : ($^O =~ / ^ ( os390 ) $ /ix)
46                                        ? 10
47                                        : 5;
48
49 # The list of test numbers of the problematic tests.
50 my %problematical_tests;
51
52 # If any %problematical_tests fails in one of these locales, it is
53 # considered a TODO.
54 my %known_bad_locales = (
55                           irix => qr/ ^ (?: cs | hu | sk ) $/x,
56                           darwin => qr/ ^ lt_LT.ISO8859 /ix,
57                           os390 => qr/ ^ italian /ix,
58                         );
59
60 # cygwin isn't returning proper radix length in this locale, but supposedly to
61 # be fixed in later versions.
62 if ($^O eq 'cygwin' && version->new(($Config{osvers} =~ /^(\d+(?:\.\d+)+)/)[0]) le v2.4.1) {
63     $known_bad_locales{'cygwin'} = qr/ ^ ps_AF /ix;
64 }
65
66 use Dumpvalue;
67
68 my $dumper = Dumpvalue->new(
69                             tick => qq{"},
70                             quoteHighBit => 0,
71                             unctrl => "quote"
72                            );
73
74 sub debug {
75   return unless $debug;
76   my($mess) = join "", '# ', @_;
77   chomp $mess;
78   print STDERR $dumper->stringify($mess,1), "\n";
79 }
80
81 sub note {
82     local $debug = 1;
83     debug @_;
84 }
85
86 sub debug_more {
87   return unless $debug > 1;
88   return debug(@_);
89 }
90
91 sub debugf {
92     printf STDERR @_ if $debug;
93 }
94
95 $a = 'abc %9';
96
97 my $test_num = 0;
98
99 sub ok {
100     my ($result, $message) = @_;
101     $message = "" unless defined $message;
102
103     print 'not ' unless ($result);
104     print "ok " . ++$test_num;
105     print " $message";
106     print "\n";
107     return ($result) ? 1 : 0;
108 }
109
110 sub skip {
111     return ok 1, "skipped: " . shift;
112 }
113
114 sub fail {
115     return ok 0, shift;
116 }
117
118 # First we'll do a lot of taint checking for locales.
119 # This is the easiest to test, actually, as any locale,
120 # even the default locale will taint under 'use locale'.
121
122 sub is_tainted { # hello, camel two.
123     no warnings 'uninitialized' ;
124     my $dummy;
125     local $@;
126     not eval { $dummy = join("", @_), kill 0; 1 }
127 }
128
129 sub check_taint ($;$) {
130     my $message_tail = $_[1] // "";
131
132     # Extra blanks are so aligns with taint_not output
133     $message_tail = ":     $message_tail" if $message_tail;
134     ok is_tainted($_[0]), "verify that is tainted$message_tail";
135 }
136
137 sub check_taint_not ($;$) {
138     my $message_tail = $_[1] // "";
139     $message_tail = ":  $message_tail" if $message_tail;
140     ok((not is_tainted($_[0])), "verify that isn't tainted$message_tail");
141 }
142
143 foreach my $category (qw(ALL COLLATE CTYPE MESSAGES MONETARY NUMERIC TIME)) {
144     my $short_result = locales_enabled($category);
145     ok ($short_result == 0 || $short_result == 1,
146         "Verify locales_enabled('$category') returns 0 or 1");
147     debug("locales_enabled('$category') returned '$short_result'");
148     my $long_result = locales_enabled("LC_$category");
149     if (! ok ($long_result == $short_result,
150               "   and locales_enabled('LC_$category') returns "
151             . "the same value")
152     ) {
153         debug("locales_enabled('LC_$category') returned $long_result");
154     }
155 }
156
157 "\tb\t" =~ /^m?(\s)(.*)\1$/;
158 check_taint_not   $&, "not tainted outside 'use locale'";
159 ;
160
161 use locale;     # engage locale and therefore locale taint.
162
163 # BE SURE TO COPY ANYTHING YOU ADD to these tests to the block below for
164 # ":notcharacters"
165
166 check_taint_not   $a, '$a';
167
168 check_taint       uc($a), 'uc($a)';
169 check_taint       "\U$a", '"\U$a"';
170 check_taint       ucfirst($a), 'ucfirst($a)';
171 check_taint       "\u$a", '"\u$a"';
172 check_taint       lc($a), 'lc($a)';
173 check_taint       fc($a), 'fc($a)';
174 check_taint       "\L$a", '"\L$a"';
175 check_taint       "\F$a", '"\F$a"';
176 check_taint       lcfirst($a), 'lcfirst($a)';
177 check_taint       "\l$a", '"\l$a"';
178
179 check_taint_not  sprintf('%e', 123.456), "sprintf('%e', 123.456)";
180 check_taint_not  sprintf('%f', 123.456), "sprintf('%f', 123.456)";
181 check_taint_not  sprintf('%g', 123.456), "sprintf('%g', 123.456)";
182 check_taint_not  sprintf('%d', 123.456), "sprintf('%d', 123.456)";
183 check_taint_not  sprintf('%x', 123.456), "sprintf('%x', 123.456)";
184
185 $_ = $a;        # untaint $_
186
187 $_ = uc($a);    # taint $_
188
189 check_taint      $_, '$_ = uc($a)';
190
191 /(\w)/; # taint $&, $`, $', $+, $1.
192 check_taint      $&, "\$& from /(\\w)/";
193 check_taint      $`, "\t\$`";
194 check_taint      $', "\t\$'";
195 check_taint      $+, "\t\$+";
196 check_taint      $1, "\t\$1";
197 check_taint_not  $2, "\t\$2";
198
199 /(.)/;  # untaint $&, $`, $', $+, $1.
200 check_taint_not  $&, "\$& from /(.)/";
201 check_taint_not  $`, "\t\$`";
202 check_taint_not  $', "\t\$'";
203 check_taint_not  $+, "\t\$+";
204 check_taint_not  $1, "\t\$1";
205 check_taint_not  $2, "\t\$2";
206
207 /(\W)/; # taint $&, $`, $', $+, $1.
208 check_taint      $&, "\$& from /(\\W)/";
209 check_taint      $`, "\t\$`";
210 check_taint      $', "\t\$'";
211 check_taint      $+, "\t\$+";
212 check_taint      $1, "\t\$1";
213 check_taint_not  $2, "\t\$2";
214
215 /(.)/;  # untaint $&, $`, $', $+, $1.
216 check_taint_not  $&, "\$& from /(.)/";
217 check_taint_not  $`, "\t\$`";
218 check_taint_not  $', "\t\$'";
219 check_taint_not  $+, "\t\$+";
220 check_taint_not  $1, "\t\$1";
221 check_taint_not  $2, "\t\$2";
222
223 /(\s)/; # taint $&, $`, $', $+, $1.
224 check_taint      $&, "\$& from /(\\s)/";
225 check_taint      $`, "\t\$`";
226 check_taint      $', "\t\$'";
227 check_taint      $+, "\t\$+";
228 check_taint      $1, "\t\$1";
229 check_taint_not  $2, "\t\$2";
230
231 /(.)/;  # untaint $&, $`, $', $+, $1.
232 check_taint_not  $&, "\$& from /(.)/";
233
234 /(\S)/; # taint $&, $`, $', $+, $1.
235 check_taint      $&, "\$& from /(\\S)/";
236 check_taint      $`, "\t\$`";
237 check_taint      $', "\t\$'";
238 check_taint      $+, "\t\$+";
239 check_taint      $1, "\t\$1";
240 check_taint_not  $2, "\t\$2";
241
242 /(.)/;  # untaint $&, $`, $', $+, $1.
243 check_taint_not  $&, "\$& from /(.)/";
244
245 "0" =~ /(\d)/;  # taint $&, $`, $', $+, $1.
246 check_taint      $&, "\$& from /(\\d)/";
247 check_taint      $`, "\t\$`";
248 check_taint      $', "\t\$'";
249 check_taint      $+, "\t\$+";
250 check_taint      $1, "\t\$1";
251 check_taint_not  $2, "\t\$2";
252
253 /(.)/;  # untaint $&, $`, $', $+, $1.
254 check_taint_not  $&, "\$& from /(.)/";
255
256 /(\D)/; # taint $&, $`, $', $+, $1.
257 check_taint      $&, "\$& from /(\\D)/";
258 check_taint      $`, "\t\$`";
259 check_taint      $', "\t\$'";
260 check_taint      $+, "\t\$+";
261 check_taint      $1, "\t\$1";
262 check_taint_not  $2, "\t\$2";
263
264 /(.)/;  # untaint $&, $`, $', $+, $1.
265 check_taint_not  $&, "\$& from /(.)/";
266
267 /([[:alnum:]])/;        # taint $&, $`, $', $+, $1.
268 check_taint      $&, "\$& from /([[:alnum:]])/";
269 check_taint      $`, "\t\$`";
270 check_taint      $', "\t\$'";
271 check_taint      $+, "\t\$+";
272 check_taint      $1, "\t\$1";
273 check_taint_not  $2, "\t\$2";
274
275 /(.)/;  # untaint $&, $`, $', $+, $1.
276 check_taint_not  $&, "\$& from /(.)/";
277
278 /([[:^alnum:]])/;       # taint $&, $`, $', $+, $1.
279 check_taint      $&, "\$& from /([[:^alnum:]])/";
280 check_taint      $`, "\t\$`";
281 check_taint      $', "\t\$'";
282 check_taint      $+, "\t\$+";
283 check_taint      $1, "\t\$1";
284 check_taint_not  $2, "\t\$2";
285
286 "a" =~ /(a)|(\w)/;      # taint $&, $`, $', $+, $1.
287 check_taint      $&, "\$& from /(a)|(\\w)/";
288 check_taint      $`, "\t\$`";
289 check_taint      $', "\t\$'";
290 check_taint      $+, "\t\$+";
291 check_taint      $1, "\t\$1";
292 ok($1 eq 'a', ("\t" x 5) . "\$1 is 'a'");
293 ok(! defined $2, ("\t" x 5) . "\$2 is undefined");
294 check_taint_not  $2, "\t\$2";
295 check_taint_not  $3, "\t\$3";
296
297 /(.)/;  # untaint $&, $`, $', $+, $1.
298 check_taint_not  $&, "\$& from /(.)/";
299
300 "\N{CYRILLIC SMALL LETTER A}" =~ /(\N{CYRILLIC CAPITAL LETTER A})/i;    # no tainting because no locale dependence
301 check_taint_not      $&, "\$& from /(\\N{CYRILLIC CAPITAL LETTER A})/i";
302 check_taint_not      $`, "\t\$`";
303 check_taint_not      $', "\t\$'";
304 check_taint_not      $+, "\t\$+";
305 check_taint_not      $1, "\t\$1";
306 ok($1 eq "\N{CYRILLIC SMALL LETTER A}", ("\t" x 4) . "\t\$1 is 'small cyrillic a'");
307 check_taint_not      $2, "\t\$2";
308
309 /(.)/;  # untaint $&, $`, $', $+, $1.
310 check_taint_not  $&, "\$& from /./";
311
312 "(\N{KELVIN SIGN})" =~ /(\N{KELVIN SIGN})/i;    # taints because depends on locale
313 check_taint      $&, "\$& from /(\\N{KELVIN SIGN})/i";
314 check_taint      $`, "\t\$`";
315 check_taint      $', "\t\$'";
316 check_taint      $+, "\t\$+";
317 check_taint      $1, "\t\$1";
318 check_taint_not      $2, "\t\$2";
319
320 /(.)/;  # untaint $&, $`, $', $+, $1.
321 check_taint_not  $&, "\$& from /(.)/";
322
323 "a:" =~ /(.)\b(.)/;     # taint $&, $`, $', $+, $1.
324 check_taint      $&, "\$& from /(.)\\b(.)/";
325 check_taint      $`, "\t\$`";
326 check_taint      $', "\t\$'";
327 check_taint      $+, "\t\$+";
328 check_taint      $1, "\t\$1";
329 check_taint      $2, "\t\$2";
330 check_taint_not  $3, "\t\$3";
331
332 /(.)/;  # untaint $&, $`, $', $+, $1.
333 check_taint_not  $&, "\$& from /./";
334
335 "aa" =~ /(.)\B(.)/;     # taint $&, $`, $', $+, $1.
336 check_taint      $&, "\$& from /(.)\\B(.)/";
337 check_taint      $`, "\t\$`";
338 check_taint      $', "\t\$'";
339 check_taint      $+, "\t\$+";
340 check_taint      $1, "\t\$1";
341 check_taint      $2, "\t\$2";
342 check_taint_not  $3, "\t\$3";
343
344 /(.)/;  # untaint $&, $`, $', $+, $1.
345 check_taint_not  $&, "\$& from /./";
346
347 "aaa" =~ /(.).(\1)/i;   # notaint because not locale dependent
348 check_taint_not      $&, "\$ & from /(.).(\\1)/";
349 check_taint_not      $`, "\t\$`";
350 check_taint_not      $', "\t\$'";
351 check_taint_not      $+, "\t\$+";
352 check_taint_not      $1, "\t\$1";
353 check_taint_not      $2, "\t\$2";
354 check_taint_not      $3, "\t\$3";
355
356 /(.)/;  # untaint $&, $`, $', $+, $1.
357 check_taint_not  $&, "\$ & from /./";
358
359 $_ = $a;        # untaint $_
360
361 check_taint_not  $_, 'untainting $_ works';
362
363 /(b)/;          # this must not taint
364 check_taint_not  $&, "\$ & from /(b)/";
365 check_taint_not  $`, "\t\$`";
366 check_taint_not  $', "\t\$'";
367 check_taint_not  $+, "\t\$+";
368 check_taint_not  $1, "\t\$1";
369 check_taint_not  $2, "\t\$2";
370
371 $_ = $a;        # untaint $_
372
373 check_taint_not  $_, 'untainting $_ works';
374
375 $b = uc($a);    # taint $b
376 s/(.+)/$b/;     # this must taint only the $_
377
378 check_taint      $_, '$_ (wasn\'t tainted) from s/(.+)/$b/ where $b is tainted';
379 check_taint_not  $&, "\t\$&";
380 check_taint_not  $`, "\t\$`";
381 check_taint_not  $', "\t\$'";
382 check_taint_not  $+, "\t\$+";
383 check_taint_not  $1, "\t\$1";
384 check_taint_not  $2, "\t\$2";
385
386 $_ = $a;        # untaint $_
387
388 s/(.+)/b/;      # this must not taint
389 check_taint_not  $_, '$_ (wasn\'t tainted) from s/(.+)/b/';
390 check_taint_not  $&, "\t\$&";
391 check_taint_not  $`, "\t\$`";
392 check_taint_not  $', "\t\$'";
393 check_taint_not  $+, "\t\$+";
394 check_taint_not  $1, "\t\$1";
395 check_taint_not  $2, "\t\$2";
396
397 $b = $a;        # untaint $b
398
399 ($b = $a) =~ s/\w/$&/;
400 check_taint      $b, '$b from ($b = $a) =~ s/\w/$&/';   # $b should be tainted.
401 check_taint_not  $a, '$a from ($b = $a) =~ s/\w/$&/';   # $a should be not.
402
403 $_ = $a;        # untaint $_
404
405 s/(\w)/\l$1/;   # this must taint
406 check_taint      $_, '$_ (wasn\'t tainted) from s/(\w)/\l$1/,'; # this must taint
407 check_taint      $&, "\t\$&";
408 check_taint      $`, "\t\$`";
409 check_taint      $', "\t\$'";
410 check_taint      $+, "\t\$+";
411 check_taint      $1, "\t\$1";
412 check_taint_not  $2, "\t\$2";
413
414 $_ = $a;        # untaint $_
415
416 s/(\w)/\L$1/;   # this must taint
417 check_taint      $_, '$_ (wasn\'t tainted) from s/(\w)/\L$1/,';
418 check_taint      $&, "\t\$&";
419 check_taint      $`, "\t\$`";
420 check_taint      $', "\t\$'";
421 check_taint      $+, "\t\$+";
422 check_taint      $1, "\t\$1";
423 check_taint_not  $2, "\t\$2";
424
425 $_ = $a;        # untaint $_
426
427 s/(\w)/\u$1/;   # this must taint
428 check_taint      $_, '$_ (wasn\'t tainted) from s/(\w)/\u$1/';
429 check_taint      $&, "\t\$&";
430 check_taint      $`, "\t\$`";
431 check_taint      $', "\t\$'";
432 check_taint      $+, "\t\$+";
433 check_taint      $1, "\t\$1";
434 check_taint_not  $2, "\t\$2";
435
436 $_ = $a;        # untaint $_
437
438 s/(\w)/\U$1/;   # this must taint
439 check_taint      $_, '$_ (wasn\'t tainted) from s/(\w)/\U$1/';
440 check_taint      $&, "\t\$&";
441 check_taint      $`, "\t\$`";
442 check_taint      $', "\t\$'";
443 check_taint      $+, "\t\$+";
444 check_taint      $1, "\t\$1";
445 check_taint_not  $2, "\t\$2";
446
447 # After all this tainting $a should be cool.
448
449 check_taint_not  $a, '$a still not tainted';
450
451 "a" =~ /([a-z])/;
452 check_taint_not $1, '"a" =~ /([a-z])/';
453 "foo.bar_baz" =~ /^(.*)[._](.*?)$/;  # Bug 120675
454 check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
455
456 # BE SURE TO COPY ANYTHING YOU ADD to the block below
457
458 {   # This is just the previous tests copied here with a different
459     # compile-time pragma.
460
461     use locale ':not_characters'; # engage restricted locale with different
462                                   # tainting rules
463     check_taint_not   $a, '$a';
464
465     check_taint_not   uc($a), 'uc($a)';
466     check_taint_not   "\U$a", '"\U$a"';
467     check_taint_not   ucfirst($a), 'ucfirst($a)';
468     check_taint_not   "\u$a", '"\u$a"';
469     check_taint_not   lc($a), 'lc($a)';
470     check_taint_not   fc($a), 'fc($a)';
471     check_taint_not   "\L$a", '"\L$a"';
472     check_taint_not   "\F$a", '"\F$a"';
473     check_taint_not   lcfirst($a), 'lcfirst($a)';
474     check_taint_not   "\l$a", '"\l$a"';
475
476     check_taint_not  sprintf('%e', 123.456), "sprintf('%e', 123.456)";
477     check_taint_not  sprintf('%f', 123.456), "sprintf('%f', 123.456)";
478     check_taint_not  sprintf('%g', 123.456), "sprintf('%g', 123.456)";
479     check_taint_not  sprintf('%d', 123.456), "sprintf('%d', 123.456)";
480     check_taint_not  sprintf('%x', 123.456), "sprintf('%x', 123.456)";
481
482     $_ = $a;    # untaint $_
483
484     $_ = uc($a);
485
486     check_taint_not  $_, '$_ = uc($a)';
487
488     /(\w)/;
489     check_taint_not  $&, "\$& from /(\\w)/";
490     check_taint_not  $`, "\t\$`";
491     check_taint_not  $', "\t\$'";
492     check_taint_not  $+, "\t\$+";
493     check_taint_not  $1, "\t\$1";
494     check_taint_not  $2, "\t\$2";
495
496     /(.)/;      # untaint $&, $`, $', $+, $1.
497     check_taint_not  $&, "\$& from /(.)/";
498     check_taint_not  $`, "\t\$`";
499     check_taint_not  $', "\t\$'";
500     check_taint_not  $+, "\t\$+";
501     check_taint_not  $1, "\t\$1";
502     check_taint_not  $2, "\t\$2";
503
504     /(\W)/;
505     check_taint_not  $&, "\$& from /(\\W)/";
506     check_taint_not  $`, "\t\$`";
507     check_taint_not  $', "\t\$'";
508     check_taint_not  $+, "\t\$+";
509     check_taint_not  $1, "\t\$1";
510     check_taint_not  $2, "\t\$2";
511
512     /(.)/;      # untaint $&, $`, $', $+, $1.
513     check_taint_not  $&, "\$& from /(.)/";
514     check_taint_not  $`, "\t\$`";
515     check_taint_not  $', "\t\$'";
516     check_taint_not  $+, "\t\$+";
517     check_taint_not  $1, "\t\$1";
518     check_taint_not  $2, "\t\$2";
519
520     /(\s)/;
521     check_taint_not  $&, "\$& from /(\\s)/";
522     check_taint_not  $`, "\t\$`";
523     check_taint_not  $', "\t\$'";
524     check_taint_not  $+, "\t\$+";
525     check_taint_not  $1, "\t\$1";
526     check_taint_not  $2, "\t\$2";
527
528     /(.)/;      # untaint $&, $`, $', $+, $1.
529     check_taint_not  $&, "\$& from /(.)/";
530
531     /(\S)/;
532     check_taint_not  $&, "\$& from /(\\S)/";
533     check_taint_not  $`, "\t\$`";
534     check_taint_not  $', "\t\$'";
535     check_taint_not  $+, "\t\$+";
536     check_taint_not  $1, "\t\$1";
537     check_taint_not  $2, "\t\$2";
538
539     /(.)/;      # untaint $&, $`, $', $+, $1.
540     check_taint_not  $&, "\$& from /(.)/";
541
542     "0" =~ /(\d)/;
543     check_taint_not  $&, "\$& from /(\\d)/";
544     check_taint_not  $`, "\t\$`";
545     check_taint_not  $', "\t\$'";
546     check_taint_not  $+, "\t\$+";
547     check_taint_not  $1, "\t\$1";
548     check_taint_not  $2, "\t\$2";
549
550     /(.)/;      # untaint $&, $`, $', $+, $1.
551     check_taint_not  $&, "\$& from /(.)/";
552
553     /(\D)/;
554     check_taint_not  $&, "\$& from /(\\D)/";
555     check_taint_not  $`, "\t\$`";
556     check_taint_not  $', "\t\$'";
557     check_taint_not  $+, "\t\$+";
558     check_taint_not  $1, "\t\$1";
559     check_taint_not  $2, "\t\$2";
560
561     /(.)/;      # untaint $&, $`, $', $+, $1.
562     check_taint_not  $&, "\$& from /(.)/";
563
564     /([[:alnum:]])/;
565     check_taint_not  $&, "\$& from /([[:alnum:]])/";
566     check_taint_not  $`, "\t\$`";
567     check_taint_not  $', "\t\$'";
568     check_taint_not  $+, "\t\$+";
569     check_taint_not  $1, "\t\$1";
570     check_taint_not  $2, "\t\$2";
571
572     /(.)/;      # untaint $&, $`, $', $+, $1.
573     check_taint_not  $&, "\$& from /(.)/";
574
575     /([[:^alnum:]])/;
576     check_taint_not  $&, "\$& from /([[:^alnum:]])/";
577     check_taint_not  $`, "\t\$`";
578     check_taint_not  $', "\t\$'";
579     check_taint_not  $+, "\t\$+";
580     check_taint_not  $1, "\t\$1";
581     check_taint_not  $2, "\t\$2";
582
583     "a" =~ /(a)|(\w)/;
584     check_taint_not  $&, "\$& from /(a)|(\\w)/";
585     check_taint_not  $`, "\t\$`";
586     check_taint_not  $', "\t\$'";
587     check_taint_not  $+, "\t\$+";
588     check_taint_not  $1, "\t\$1";
589     ok($1 eq 'a', ("\t" x 5) . "\$1 is 'a'");
590     ok(! defined $2, ("\t" x 5) . "\$2 is undefined");
591     check_taint_not  $2, "\t\$2";
592     check_taint_not  $3, "\t\$3";
593
594     /(.)/;      # untaint $&, $`, $', $+, $1.
595     check_taint_not  $&, "\$& from /(.)/";
596
597     "\N{CYRILLIC SMALL LETTER A}" =~ /(\N{CYRILLIC CAPITAL LETTER A})/i;
598     check_taint_not      $&, "\$& from /(\\N{CYRILLIC CAPITAL LETTER A})/i";
599     check_taint_not      $`, "\t\$`";
600     check_taint_not      $', "\t\$'";
601     check_taint_not      $+, "\t\$+";
602     check_taint_not      $1, "\t\$1";
603     ok($1 eq "\N{CYRILLIC SMALL LETTER A}", ("\t" x 4) . "\t\$1 is 'small cyrillic a'");
604     check_taint_not      $2, "\t\$2";
605
606     /(.)/;      # untaint $&, $`, $', $+, $1.
607     check_taint_not  $&, "\$& from /./";
608
609     "(\N{KELVIN SIGN})" =~ /(\N{KELVIN SIGN})/i;
610     check_taint_not  $&, "\$& from /(\\N{KELVIN SIGN})/i";
611     check_taint_not  $`, "\t\$`";
612     check_taint_not  $', "\t\$'";
613     check_taint_not  $+, "\t\$+";
614     check_taint_not  $1, "\t\$1";
615     check_taint_not      $2, "\t\$2";
616
617     /(.)/;      # untaint $&, $`, $', $+, $1.
618     check_taint_not  $&, "\$& from /(.)/";
619
620     "a:" =~ /(.)\b(.)/;
621     check_taint_not  $&, "\$& from /(.)\\b(.)/";
622     check_taint_not  $`, "\t\$`";
623     check_taint_not  $', "\t\$'";
624     check_taint_not  $+, "\t\$+";
625     check_taint_not  $1, "\t\$1";
626     check_taint_not  $2, "\t\$2";
627     check_taint_not  $3, "\t\$3";
628
629     /(.)/;      # untaint $&, $`, $', $+, $1.
630     check_taint_not  $&, "\$& from /./";
631
632     "aa" =~ /(.)\B(.)/;
633     check_taint_not  $&, "\$& from /(.)\\B(.)/";
634     check_taint_not  $`, "\t\$`";
635     check_taint_not  $', "\t\$'";
636     check_taint_not  $+, "\t\$+";
637     check_taint_not  $1, "\t\$1";
638     check_taint_not  $2, "\t\$2";
639     check_taint_not  $3, "\t\$3";
640
641     /(.)/;      # untaint $&, $`, $', $+, $1.
642     check_taint_not  $&, "\$& from /./";
643
644     "aaa" =~ /(.).(\1)/i;       # notaint because not locale dependent
645     check_taint_not      $&, "\$ & from /(.).(\\1)/";
646     check_taint_not      $`, "\t\$`";
647     check_taint_not      $', "\t\$'";
648     check_taint_not      $+, "\t\$+";
649     check_taint_not      $1, "\t\$1";
650     check_taint_not      $2, "\t\$2";
651     check_taint_not      $3, "\t\$3";
652
653     /(.)/;      # untaint $&, $`, $', $+, $1.
654     check_taint_not  $&, "\$ & from /./";
655
656     $_ = $a;    # untaint $_
657
658     check_taint_not  $_, 'untainting $_ works';
659
660     /(b)/;
661     check_taint_not  $&, "\$ & from /(b)/";
662     check_taint_not  $`, "\t\$`";
663     check_taint_not  $', "\t\$'";
664     check_taint_not  $+, "\t\$+";
665     check_taint_not  $1, "\t\$1";
666     check_taint_not  $2, "\t\$2";
667
668     $_ = $a;    # untaint $_
669
670     check_taint_not  $_, 'untainting $_ works';
671
672     s/(.+)/b/;
673     check_taint_not  $_, '$_ (wasn\'t tainted) from s/(.+)/b/';
674     check_taint_not  $&, "\t\$&";
675     check_taint_not  $`, "\t\$`";
676     check_taint_not  $', "\t\$'";
677     check_taint_not  $+, "\t\$+";
678     check_taint_not  $1, "\t\$1";
679     check_taint_not  $2, "\t\$2";
680
681     $b = $a;    # untaint $b
682
683     ($b = $a) =~ s/\w/$&/;
684     check_taint_not     $b, '$b from ($b = $a) =~ s/\w/$&/';
685     check_taint_not  $a, '$a from ($b = $a) =~ s/\w/$&/';
686
687     $_ = $a;    # untaint $_
688
689     s/(\w)/\l$1/;
690     check_taint_not     $_, '$_ (wasn\'t tainted) from s/(\w)/\l$1/,';  # this must taint
691     check_taint_not     $&, "\t\$&";
692     check_taint_not     $`, "\t\$`";
693     check_taint_not     $', "\t\$'";
694     check_taint_not     $+, "\t\$+";
695     check_taint_not     $1, "\t\$1";
696     check_taint_not  $2, "\t\$2";
697
698     $_ = $a;    # untaint $_
699
700     s/(\w)/\L$1/;
701     check_taint_not     $_, '$_ (wasn\'t tainted) from s/(\w)/\L$1/,';
702     check_taint_not     $&, "\t\$&";
703     check_taint_not     $`, "\t\$`";
704     check_taint_not     $', "\t\$'";
705     check_taint_not     $+, "\t\$+";
706     check_taint_not     $1, "\t\$1";
707     check_taint_not  $2, "\t\$2";
708
709     $_ = $a;    # untaint $_
710
711     s/(\w)/\u$1/;
712     check_taint_not     $_, '$_ (wasn\'t tainted) from s/(\w)/\u$1/';
713     check_taint_not     $&, "\t\$&";
714     check_taint_not     $`, "\t\$`";
715     check_taint_not     $', "\t\$'";
716     check_taint_not     $+, "\t\$+";
717     check_taint_not     $1, "\t\$1";
718     check_taint_not  $2, "\t\$2";
719
720     $_ = $a;    # untaint $_
721
722     s/(\w)/\U$1/;
723     check_taint_not     $_, '$_ (wasn\'t tainted) from s/(\w)/\U$1/';
724     check_taint_not     $&, "\t\$&";
725     check_taint_not     $`, "\t\$`";
726     check_taint_not     $', "\t\$'";
727     check_taint_not     $+, "\t\$+";
728     check_taint_not     $1, "\t\$1";
729     check_taint_not  $2, "\t\$2";
730
731     # After all this tainting $a should be cool.
732
733     check_taint_not  $a, '$a still not tainted';
734
735     "a" =~ /([a-z])/;
736     check_taint_not $1, '"a" =~ /([a-z])/';
737     "foo.bar_baz" =~ /^(.*)[._](.*?)$/;  # Bug 120675
738     check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
739
740 }
741
742 # Here are in scope of 'use locale'
743
744 # I think we've seen quite enough of taint.
745 # Let us do some *real* locale work now,
746 # unless setlocale() is missing (i.e. minitest).
747
748 # The test number before our first setlocale()
749 my $final_without_setlocale = $test_num;
750
751 # Find locales.
752
753 debug "Scanning for locales...\n";
754
755 require POSIX; import POSIX ':locale_h';
756
757 my $categories = [ 'LC_CTYPE', 'LC_NUMERIC', 'LC_ALL' ];
758 debug "Scanning for just compatible";
759 my @Locale = find_locales($categories);
760 debug "Scanning for even incompatible";
761 my @include_incompatible_locales = find_locales($categories,
762                                                 'even incompatible locales');
763
764 # The locales included in the incompatible list that aren't in the compatible
765 # one.
766 my @incompatible_locales;
767
768 if (@Locale < @include_incompatible_locales) {
769     my %seen;
770     @seen{@Locale} = ();
771
772     foreach my $item (@include_incompatible_locales) {
773         push @incompatible_locales, $item unless exists $seen{$item};
774     }
775
776     # For each bad locale, switch into it to find out why it's incompatible
777     for my $bad_locale (@incompatible_locales) {
778         my @warnings;
779
780         use warnings 'locale';
781
782         local $SIG{__WARN__} = sub {
783             my $warning = $_[0];
784             chomp $warning;
785             push @warnings, ($warning =~ s/\n/\n# /sgr);
786         };
787
788         debug "Trying incompatible $bad_locale";
789         my $ret = setlocale(&POSIX::LC_CTYPE, $bad_locale);
790
791         my $message = "testing of locale '$bad_locale' is skipped";
792         if (@warnings) {
793             skip $message . ":\n# " . join "\n# ", @warnings;
794         }
795         elsif (! $ret) {
796             skip("$message:\n#"
797                . " setlocale(&POSIX::LC_CTYPE, '$bad_locale') failed");
798         }
799         else {
800             fail $message . ", because it is was found to be incompatible with"
801                           . " Perl, but could not discern reason";
802         }
803     }
804 }
805
806 debug "Locales =\n";
807 for ( @Locale ) {
808     debug "$_\n";
809 }
810
811 unless (@Locale) {
812     print "1..$test_num\n";
813     exit;
814 }
815
816
817 setlocale(&POSIX::LC_ALL, "C");
818
819 my %posixes;
820
821 my %Problem;
822 my %Okay;
823 my %Known_bad_locale;   # Failed test for a locale known to be bad
824 my %Testing;
825 my @Added_alpha;   # Alphas that aren't in the C locale.
826 my %test_names;
827
828 sub disp_chars {
829     # This returns a display string denoting the input parameter @_, each
830     # entry of which is a single character in the range 0-255.  The first part
831     # of the output is a string of the characters in @_ that are ASCII
832     # graphics, and hence unambiguously displayable.  They are given by code
833     # point order.  The second part is the remaining code points, the ordinals
834     # of which are each displayed as 2-digit hex.  Blanks are inserted so as
835     # to keep anything from the first part looking like a 2-digit hex number.
836
837     no locale;
838     my @chars = sort { ord $a <=> ord $b } @_;
839     my $output = "";
840     my $range_start;
841     my $start_class;
842     push @chars, chr(258);  # This sentinel simplifies the loop termination
843                             # logic
844     foreach my $i (0 .. @chars - 1) {
845         my $char = $chars[$i];
846         my $range_end;
847         my $class;
848
849         # We avoid using [:posix:] classes, as these are being tested in this
850         # file.  Each equivalence class below is for things that can appear in
851         # a range; those that can't be in a range have class -1.  0 for those
852         # which should be output in hex; and >0 for the other ranges
853         if ($char =~ /[A-Z]/) {
854             $class = 2;
855         }
856         elsif ($char =~ /[a-z]/) {
857             $class = 3;
858         }
859         elsif ($char =~ /[0-9]/) {
860             $class = 4;
861         }
862         # Uncomment to get literal punctuation displayed instead of hex
863         #elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
864         #    $class = -1;    # Punct never appears in a range
865         #}
866         else {
867             $class = 0;     # Output in hex
868         }
869
870         if (! defined $range_start) {
871             if ($class < 0) {
872                 $output .= " " . $char;
873             }
874             else {
875                 $range_start = ord $char;
876                 $start_class = $class;
877             }
878         } # A range ends if not consecutive, or the class-type changes
879         elsif (ord $char != ($range_end = ord($chars[$i-1])) + 1
880               || $class != $start_class)
881         {
882
883             # Here, the current character is not in the range.  This means the
884             # previous character must have been.  Output the range up through
885             # that one.
886             my $range_length = $range_end - $range_start + 1;
887             if ($start_class > 0) {
888                 $output .= " " . chr($range_start);
889                 $output .= "-" . chr($range_end) if $range_length > 1;
890             }
891             else {
892                 $output .= sprintf(" %02X", $range_start);
893                 $output .= sprintf("-%02X", $range_end) if $range_length > 1;
894             }
895
896             # Handle the new current character, as potentially beginning a new
897             # range
898             undef $range_start;
899             redo;
900         }
901     }
902
903     $output =~ s/^ //;
904     return $output;
905 }
906
907 sub disp_str ($) {
908     my $string = shift;
909
910     # Displays the string unambiguously.  ASCII printables are always output
911     # as-is, though perhaps separated by blanks from other characters.  If
912     # entirely printable ASCII, just returns the string.  Otherwise if valid
913     # UTF-8 it uses the character names for non-printable-ASCII.  Otherwise it
914     # outputs hex for each non-ASCII-printable byte.
915
916     return $string if $string =~ / ^ [[:print:]]* $/xa;
917
918     my $result = "";
919     my $prev_was_punct = 1; # Beginning is considered punct
920     if (utf8::valid($string) && utf8::is_utf8($string)) {
921         use charnames ();
922         foreach my $char (split "", $string) {
923
924             # Keep punctuation adjacent to other characters; otherwise
925             # separate them with a blank
926             if ($char =~ /[[:punct:]]/a) {
927                 $result .= $char;
928                 $prev_was_punct = 1;
929             }
930             elsif ($char =~ /[[:print:]]/a) {
931                 $result .= "  " unless $prev_was_punct;
932                 $result .= $char;
933                 $prev_was_punct = 0;
934             }
935             else {
936                 $result .= "  " unless $prev_was_punct;
937                 my $name = charnames::viacode(ord $char);
938                 $result .= (defined $name) ? $name : ':unknown:';
939                 $prev_was_punct = 0;
940             }
941         }
942     }
943     else {
944         use bytes;
945         foreach my $char (split "", $string) {
946             if ($char =~ /[[:punct:]]/a) {
947                 $result .= $char;
948                 $prev_was_punct = 1;
949             }
950             elsif ($char =~ /[[:print:]]/a) {
951                 $result .= " " unless $prev_was_punct;
952                 $result .= $char;
953                 $prev_was_punct = 0;
954             }
955             else {
956                 $result .= " " unless $prev_was_punct;
957                 $result .= sprintf("%02X", ord $char);
958                 $prev_was_punct = 0;
959             }
960         }
961     }
962
963     return $result;
964 }
965
966 sub report_result {
967     my ($Locale, $i, $pass_fail, $message) = @_;
968     if ($pass_fail) {
969         push @{$Okay{$i}}, $Locale;
970     }
971     else {
972         $message //= "";
973         $message = "  ($message)" if $message;
974         $Known_bad_locale{$i}{$Locale} = 1 if exists $known_bad_locales{$^O}
975                                          && $Locale =~ $known_bad_locales{$^O};
976         $Problem{$i}{$Locale} = 1;
977         debug "failed $i ($test_names{$i}) with locale '$Locale'$message\n";
978     }
979 }
980
981 sub report_multi_result {
982     my ($Locale, $i, $results_ref) = @_;
983
984     # $results_ref points to an array, each element of which is a character that was
985     # in error for this test numbered '$i'.  If empty, the test passed
986
987     my $message = "";
988     if (@$results_ref) {
989         $message = join " ", "for", disp_chars(@$results_ref);
990     }
991     report_result($Locale, $i, @$results_ref == 0, $message);
992 }
993
994 my $first_locales_test_number = $final_without_setlocale
995                               + 1 + @incompatible_locales;
996 my $locales_test_number;
997 my $not_necessarily_a_problem_test_number;
998 my $first_casing_test_number;
999 my %setlocale_failed;   # List of locales that setlocale() didn't work on
1000
1001 foreach my $Locale (@Locale) {
1002     $locales_test_number = $first_locales_test_number - 1;
1003     debug "\n";
1004     debug "Locale = $Locale\n";
1005
1006     unless (setlocale(&POSIX::LC_ALL, $Locale)) {
1007         $setlocale_failed{$Locale} = $Locale;
1008         next;
1009     }
1010
1011     # We test UTF-8 locales only under ':not_characters';  It is easier to
1012     # test them in other test files than here.  Non- UTF-8 locales are tested
1013     # only under plain 'use locale', as otherwise we would have to convert
1014     # everything in them to Unicode.
1015
1016     my %UPPER = ();     # All alpha X for which uc(X) == X and lc(X) != X
1017     my %lower = ();     # All alpha X for which lc(X) == X and uc(X) != X
1018     my %BoThCaSe = ();  # All alpha X for which uc(X) == lc(X) == X
1019
1020     my $is_utf8_locale = is_locale_utf8($Locale);
1021
1022     debug "is utf8 locale? = $is_utf8_locale\n";
1023
1024     debug "radix = " . disp_str(localeconv()->{decimal_point}) . "\n";
1025
1026     if (! $is_utf8_locale) {
1027         use locale;
1028         @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
1029         @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
1030         @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
1031         @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
1032         @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
1033         @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
1034         @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
1035         @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
1036         @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
1037         @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
1038         @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
1039         @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
1040         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
1041         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
1042         @{$posixes{'cased'}} = grep /[[:upper:][:lower:]]/i, map {chr } 0..255;
1043
1044         # Sieve the uppercase and the lowercase.
1045
1046         for (@{$posixes{'word'}}) {
1047             if (/[^\d_]/) { # skip digits and the _
1048                 if (uc($_) eq $_) {
1049                     $UPPER{$_} = $_;
1050                 }
1051                 if (lc($_) eq $_) {
1052                     $lower{$_} = $_;
1053                 }
1054             }
1055         }
1056     }
1057     else {
1058         use locale ':not_characters';
1059         @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
1060         @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
1061         @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
1062         @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
1063         @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
1064         @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
1065         @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
1066         @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
1067         @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
1068         @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
1069         @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
1070         @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
1071         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
1072         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
1073         @{$posixes{'cased'}} = grep /[[:upper:][:lower:]]/i, map {chr } 0..255;
1074         for (@{$posixes{'word'}}) {
1075             if (/[^\d_]/) { # skip digits and the _
1076                 if (uc($_) eq $_) {
1077                     $UPPER{$_} = $_;
1078                 }
1079                 if (lc($_) eq $_) {
1080                     $lower{$_} = $_;
1081                 }
1082             }
1083         }
1084     }
1085
1086     # Ordered, where possible,  in groups of "this is a subset of the next
1087     # one"
1088     debug ":upper:  = ", disp_chars(@{$posixes{'upper'}}), "\n";
1089     debug ":lower:  = ", disp_chars(@{$posixes{'lower'}}), "\n";
1090     debug ":cased:  = ", disp_chars(@{$posixes{'cased'}}), "\n";
1091     debug ":alpha:  = ", disp_chars(@{$posixes{'alpha'}}), "\n";
1092     debug ":alnum:  = ", disp_chars(@{$posixes{'alnum'}}), "\n";
1093     debug ' \w      = ', disp_chars(@{$posixes{'word'}}), "\n";
1094     debug ":graph:  = ", disp_chars(@{$posixes{'graph'}}), "\n";
1095     debug ":print:  = ", disp_chars(@{$posixes{'print'}}), "\n";
1096     debug ' \d      = ', disp_chars(@{$posixes{'digit'}}), "\n";
1097     debug ":xdigit: = ", disp_chars(@{$posixes{'xdigit'}}), "\n";
1098     debug ":blank:  = ", disp_chars(@{$posixes{'blank'}}), "\n";
1099     debug ' \s      = ', disp_chars(@{$posixes{'space'}}), "\n";
1100     debug ":punct:  = ", disp_chars(@{$posixes{'punct'}}), "\n";
1101     debug ":cntrl:  = ", disp_chars(@{$posixes{'cntrl'}}), "\n";
1102     debug ":ascii:  = ", disp_chars(@{$posixes{'ascii'}}), "\n";
1103
1104     foreach (keys %UPPER) {
1105
1106         $BoThCaSe{$_}++ if exists $lower{$_};
1107     }
1108     foreach (keys %lower) {
1109         $BoThCaSe{$_}++ if exists $UPPER{$_};
1110     }
1111     foreach (keys %BoThCaSe) {
1112         delete $UPPER{$_};
1113         delete $lower{$_};
1114     }
1115
1116     my %Unassigned;
1117     foreach my $ord ( 0 .. 255 ) {
1118         $Unassigned{chr $ord} = 1;
1119     }
1120     foreach my $class (keys %posixes) {
1121         foreach my $char (@{$posixes{$class}}) {
1122             delete $Unassigned{$char};
1123         }
1124     }
1125
1126     debug "UPPER    = ", disp_chars(sort { ord $a <=> ord $b } keys %UPPER), "\n";
1127     debug "lower    = ", disp_chars(sort { ord $a <=> ord $b } keys %lower), "\n";
1128     debug "BoThCaSe = ", disp_chars(sort { ord $a <=> ord $b } keys %BoThCaSe), "\n";
1129     debug "Unassigned = ", disp_chars(sort { ord $a <=> ord $b } keys %Unassigned), "\n";
1130
1131     my @failures;
1132     my @fold_failures;
1133     foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
1134         my $ok;
1135         my $fold_ok;
1136         if ($is_utf8_locale) {
1137             use locale ':not_characters';
1138             $ok = $x =~ /[[:upper:]]/;
1139             $fold_ok = $x =~ /[[:lower:]]/i;
1140         }
1141         else {
1142             use locale;
1143             $ok = $x =~ /[[:upper:]]/;
1144             $fold_ok = $x =~ /[[:lower:]]/i;
1145         }
1146         push @failures, $x unless $ok;
1147         push @fold_failures, $x unless $fold_ok;
1148     }
1149     $locales_test_number++;
1150     $first_casing_test_number = $locales_test_number;
1151     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
1152     report_multi_result($Locale, $locales_test_number, \@failures);
1153
1154     $locales_test_number++;
1155
1156     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
1157     report_multi_result($Locale, $locales_test_number, \@fold_failures);
1158
1159     undef @failures;
1160     undef @fold_failures;
1161
1162     foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
1163         my $ok;
1164         my $fold_ok;
1165         if ($is_utf8_locale) {
1166             use locale ':not_characters';
1167             $ok = $x =~ /[[:lower:]]/;
1168             $fold_ok = $x =~ /[[:upper:]]/i;
1169         }
1170         else {
1171             use locale;
1172             $ok = $x =~ /[[:lower:]]/;
1173             $fold_ok = $x =~ /[[:upper:]]/i;
1174         }
1175         push @failures, $x unless $ok;
1176         push @fold_failures, $x unless $fold_ok;
1177     }
1178
1179     $locales_test_number++;
1180     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
1181     report_multi_result($Locale, $locales_test_number, \@failures);
1182
1183     $locales_test_number++;
1184     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
1185     report_multi_result($Locale, $locales_test_number, \@fold_failures);
1186
1187     {   # Find the alphabetic characters that are not considered alphabetics
1188         # in the default (C) locale.
1189
1190         no locale;
1191
1192         @Added_alpha = ();
1193         for (keys %UPPER, keys %lower, keys %BoThCaSe) {
1194             push(@Added_alpha, $_) if (/\W/);
1195         }
1196     }
1197
1198     @Added_alpha = sort { ord $a <=> ord $b } @Added_alpha;
1199
1200     debug "Added_alpha = ", disp_chars(@Added_alpha), "\n";
1201
1202     # Cross-check the whole 8-bit character set.
1203
1204     ++$locales_test_number;
1205     my @f;
1206     $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
1207     for (map { chr } 0..255) {
1208         if ($is_utf8_locale) {
1209             use locale ':not_characters';
1210             push @f, $_ unless /[[:word:]]/ == /\w/;
1211         }
1212         else {
1213             push @f, $_ unless /[[:word:]]/ == /\w/;
1214         }
1215     }
1216     report_multi_result($Locale, $locales_test_number, \@f);
1217
1218     ++$locales_test_number;
1219     undef @f;
1220     $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1221     for (map { chr } 0..255) {
1222         if ($is_utf8_locale) {
1223             use locale ':not_characters';
1224             push @f, $_ unless /[[:digit:]]/ == /\d/;
1225         }
1226         else {
1227             push @f, $_ unless /[[:digit:]]/ == /\d/;
1228         }
1229     }
1230     report_multi_result($Locale, $locales_test_number, \@f);
1231
1232     ++$locales_test_number;
1233     undef @f;
1234     $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1235     for (map { chr } 0..255) {
1236         if ($is_utf8_locale) {
1237             use locale ':not_characters';
1238             push @f, $_ unless /[[:space:]]/ == /\s/;
1239         }
1240         else {
1241             push @f, $_ unless /[[:space:]]/ == /\s/;
1242         }
1243     }
1244     report_multi_result($Locale, $locales_test_number, \@f);
1245
1246     ++$locales_test_number;
1247     undef @f;
1248     $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1249     for (map { chr } 0..255) {
1250         if ($is_utf8_locale) {
1251             use locale ':not_characters';
1252             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1253                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1254                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1255                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1256                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1257                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1258                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1259                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1260                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1261                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1262                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1263                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1264                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1265
1266                     # effectively is what [:cased:] would be if it existed.
1267                     (/[[:upper:][:lower:]]/i xor /[^[:upper:][:lower:]]/i);
1268         }
1269         else {
1270             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1271                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1272                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1273                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1274                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1275                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1276                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1277                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1278                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1279                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1280                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1281                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1282                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1283                     (/[[:upper:][:lower:]]/i xor /[^[:upper:][:lower:]]/i);
1284         }
1285     }
1286     report_multi_result($Locale, $locales_test_number, \@f);
1287
1288     # The rules for the relationships are given in:
1289     # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1290
1291
1292     ++$locales_test_number;
1293     undef @f;
1294     $test_names{$locales_test_number} = 'Verify that [:lower:] contains at least a-z';
1295     for ('a' .. 'z') {
1296         if ($is_utf8_locale) {
1297             use locale ':not_characters';
1298             push @f, $_  unless /[[:lower:]]/;
1299         }
1300         else {
1301             push @f, $_  unless /[[:lower:]]/;
1302         }
1303     }
1304     report_multi_result($Locale, $locales_test_number, \@f);
1305
1306     ++$locales_test_number;
1307     undef @f;
1308     $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1309     for (map { chr } 0..255) {
1310         if ($is_utf8_locale) {
1311             use locale ':not_characters';
1312             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1313         }
1314         else {
1315             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1316         }
1317     }
1318     report_multi_result($Locale, $locales_test_number, \@f);
1319
1320     ++$locales_test_number;
1321     undef @f;
1322     $test_names{$locales_test_number} = 'Verify that [:upper:] contains at least A-Z';
1323     for ('A' .. 'Z') {
1324         if ($is_utf8_locale) {
1325             use locale ':not_characters';
1326             push @f, $_  unless /[[:upper:]]/;
1327         }
1328         else {
1329             push @f, $_  unless /[[:upper:]]/;
1330         }
1331     }
1332     report_multi_result($Locale, $locales_test_number, \@f);
1333
1334     ++$locales_test_number;
1335     undef @f;
1336     $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1337     for (map { chr } 0..255) {
1338         if ($is_utf8_locale) {
1339             use locale ':not_characters';
1340             push @f, $_  if /[[:upper:]]/ and ! /[[:alpha:]]/;
1341         }
1342         else {
1343             push @f, $_ if /[[:upper:]]/  and ! /[[:alpha:]]/;
1344         }
1345     }
1346     report_multi_result($Locale, $locales_test_number, \@f);
1347
1348     ++$locales_test_number;
1349     undef @f;
1350     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1351     for (map { chr } 0..255) {
1352         if ($is_utf8_locale) {
1353             use locale ':not_characters';
1354             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1355         }
1356         else {
1357             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1358         }
1359     }
1360     report_multi_result($Locale, $locales_test_number, \@f);
1361
1362     ++$locales_test_number;
1363     undef @f;
1364     $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1365     for (map { chr } 0..255) {
1366         if ($is_utf8_locale) {
1367             use locale ':not_characters';
1368             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1369         }
1370         else {
1371             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1372         }
1373     }
1374     report_multi_result($Locale, $locales_test_number, \@f);
1375
1376     ++$locales_test_number;
1377     undef @f;
1378     $test_names{$locales_test_number} = 'Verify that [:digit:] contains at least 0-9';
1379     for ('0' .. '9') {
1380         if ($is_utf8_locale) {
1381             use locale ':not_characters';
1382             push @f, $_  unless /[[:digit:]]/;
1383         }
1384         else {
1385             push @f, $_  unless /[[:digit:]]/;
1386         }
1387     }
1388     report_multi_result($Locale, $locales_test_number, \@f);
1389
1390     ++$locales_test_number;
1391     undef @f;
1392     $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1393     for (map { chr } 0..255) {
1394         if ($is_utf8_locale) {
1395             use locale ':not_characters';
1396             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1397         }
1398         else {
1399             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1400         }
1401     }
1402     report_multi_result($Locale, $locales_test_number, \@f);
1403
1404     ++$locales_test_number;
1405     undef @f;
1406     $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1407     report_result($Locale, $locales_test_number, @{$posixes{'digit'}} == 10 || @{$posixes{'digit'}} == 20);
1408
1409     ++$locales_test_number;
1410     undef @f;
1411     $test_names{$locales_test_number} = 'Verify that if there is a second set of digits in [:digit:], they are consecutive';
1412     if (@{$posixes{'digit'}} == 20) {
1413         my $previous_ord;
1414         for (map { chr } 0..255) {
1415             next unless /[[:digit:]]/;
1416             next if /[0-9]/;
1417             if (defined $previous_ord) {
1418                 if ($is_utf8_locale) {
1419                     use locale ':not_characters';
1420                     push @f, $_ if ord $_ != $previous_ord + 1;
1421                 }
1422                 else {
1423                     push @f, $_ if ord $_ != $previous_ord + 1;
1424                 }
1425             }
1426             $previous_ord = ord $_;
1427         }
1428     }
1429     report_multi_result($Locale, $locales_test_number, \@f);
1430
1431     ++$locales_test_number;
1432     undef @f;
1433     my @xdigit_digits;  # :digit: & :xdigit:
1434     $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains one or two blocks of 10 consecutive [:digit:] chars';
1435     for (map { chr } 0..255) {
1436         if ($is_utf8_locale) {
1437             use locale ':not_characters';
1438             # For utf8 locales, we actually use a stricter test: that :digit:
1439             # is a subset of :xdigit:, as we know that only 0-9 should match
1440             push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
1441         }
1442         else {
1443             push @xdigit_digits, $_ if /[[:digit:]]/ and /[[:xdigit:]]/;
1444         }
1445     }
1446     if (! $is_utf8_locale) {
1447
1448         # For non-utf8 locales, @xdigit_digits is a list of the characters
1449         # that are both :xdigit: and :digit:.  Because :digit: is stored in
1450         # increasing code point order (unless the tests above failed),
1451         # @xdigit_digits is as well.  There should be exactly 10 or
1452         # 20 of these.
1453         if (@xdigit_digits != 10 && @xdigit_digits != 20) {
1454             @f = @xdigit_digits;
1455         }
1456         else {
1457
1458             # Look for contiguity in the series, adding any wrong ones to @f
1459             my @temp = @xdigit_digits;
1460             while (@temp > 1) {
1461                 push @f, $temp[1] if ($temp[0] != $temp[1] - 1)
1462
1463                                      # Skip this test for the 0th character of
1464                                      # the second block of 10, as it won't be
1465                                      # contiguous with the previous block
1466                                      && (! defined $xdigit_digits[10]
1467                                          || $temp[1] != $xdigit_digits[10]);
1468                 shift @temp;
1469             }
1470         }
1471     }
1472
1473     report_multi_result($Locale, $locales_test_number, \@f);
1474
1475     ++$locales_test_number;
1476     undef @f;
1477     $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains at least A-F, a-f';
1478     for ('A' .. 'F', 'a' .. 'f') {
1479         if ($is_utf8_locale) {
1480             use locale ':not_characters';
1481             push @f, $_  unless /[[:xdigit:]]/;
1482         }
1483         else {
1484             push @f, $_  unless /[[:xdigit:]]/;
1485         }
1486     }
1487     report_multi_result($Locale, $locales_test_number, \@f);
1488
1489     ++$locales_test_number;
1490     undef @f;
1491     $test_names{$locales_test_number} = 'Verify that any additional members of [:xdigit:], are in groups of 6 consecutive code points';
1492     my $previous_ord;
1493     my $count = 0;
1494     for my $chr (map { chr } 0..255) {
1495         next unless $chr =~ /[[:xdigit:]]/;
1496         if ($is_utf8_locale) {
1497             next if $chr =~ /[[:digit:]]/;
1498         }
1499         else {
1500             next if grep { $chr eq $_ } @xdigit_digits;
1501         }
1502         next if $chr =~ /[A-Fa-f]/;
1503         if (defined $previous_ord) {
1504             if ($is_utf8_locale) {
1505                 use locale ':not_characters';
1506                 push @f, $chr if ord $chr != $previous_ord + 1;
1507             }
1508             else {
1509                 push @f, $chr if ord $chr != $previous_ord + 1;
1510             }
1511         }
1512         $count++;
1513         if ($count == 6) {
1514             undef $previous_ord;
1515         }
1516         else {
1517             $previous_ord = ord $chr;
1518         }
1519     }
1520     report_multi_result($Locale, $locales_test_number, \@f);
1521
1522     ++$locales_test_number;
1523     undef @f;
1524     $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1525     for (map { chr } 0..255) {
1526         if ($is_utf8_locale) {
1527             use locale ':not_characters';
1528             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1529         }
1530         else {
1531             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1532         }
1533     }
1534     report_multi_result($Locale, $locales_test_number, \@f);
1535
1536     # Note that xdigit doesn't have to be a subset of alnum
1537
1538     ++$locales_test_number;
1539     undef @f;
1540     $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1541     for (map { chr } 0..255) {
1542         if ($is_utf8_locale) {
1543             use locale ':not_characters';
1544             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1545         }
1546         else {
1547             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1548         }
1549     }
1550     report_multi_result($Locale, $locales_test_number, \@f);
1551
1552     ++$locales_test_number;
1553     undef @f;
1554     $test_names{$locales_test_number} = 'Verify that the space character is not in [:graph:]';
1555     if ($is_utf8_locale) {
1556         use locale ':not_characters';
1557         push @f, " " if " " =~ /[[:graph:]]/;
1558     }
1559     else {
1560         push @f, " " if " " =~ /[[:graph:]]/;
1561     }
1562     report_multi_result($Locale, $locales_test_number, \@f);
1563
1564     ++$locales_test_number;
1565     undef @f;
1566     $test_names{$locales_test_number} = 'Verify that [:space:] contains at least [\f\n\r\t\cK ]';
1567     for (' ', "\f", "\n", "\r", "\t", "\cK") {
1568         if ($is_utf8_locale) {
1569             use locale ':not_characters';
1570             push @f, $_  unless /[[:space:]]/;
1571         }
1572         else {
1573             push @f, $_  unless /[[:space:]]/;
1574         }
1575     }
1576     report_multi_result($Locale, $locales_test_number, \@f);
1577
1578     ++$locales_test_number;
1579     undef @f;
1580     $test_names{$locales_test_number} = 'Verify that [:blank:] contains at least [\t ]';
1581     for (' ', "\t") {
1582         if ($is_utf8_locale) {
1583             use locale ':not_characters';
1584             push @f, $_  unless /[[:blank:]]/;
1585         }
1586         else {
1587             push @f, $_  unless /[[:blank:]]/;
1588         }
1589     }
1590     report_multi_result($Locale, $locales_test_number, \@f);
1591
1592     ++$locales_test_number;
1593     undef @f;
1594     $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1595     for (map { chr } 0..255) {
1596         if ($is_utf8_locale) {
1597             use locale ':not_characters';
1598             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1599         }
1600         else {
1601             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1602         }
1603     }
1604     report_multi_result($Locale, $locales_test_number, \@f);
1605
1606     ++$locales_test_number;
1607     undef @f;
1608     $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1609     for (map { chr } 0..255) {
1610         if ($is_utf8_locale) {
1611             use locale ':not_characters';
1612             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1613         }
1614         else {
1615             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1616         }
1617     }
1618     report_multi_result($Locale, $locales_test_number, \@f);
1619
1620     ++$locales_test_number;
1621     undef @f;
1622     $test_names{$locales_test_number} = 'Verify that the space character is in [:print:]';
1623     if ($is_utf8_locale) {
1624         use locale ':not_characters';
1625         push @f, " " if " " !~ /[[:print:]]/;
1626     }
1627     else {
1628         push @f, " " if " " !~ /[[:print:]]/;
1629     }
1630     report_multi_result($Locale, $locales_test_number, \@f);
1631
1632     ++$locales_test_number;
1633     undef @f;
1634     $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1635     for (map { chr } 0..255) {
1636         if ($is_utf8_locale) {
1637             use locale ':not_characters';
1638             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1639         }
1640         else {
1641             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1642         }
1643     }
1644     report_multi_result($Locale, $locales_test_number, \@f);
1645
1646     ++$locales_test_number;
1647     undef @f;
1648     $test_names{$locales_test_number} = 'Verify that isn\'t both [:alpha:] and [:digit:]';
1649     for (map { chr } 0..255) {
1650         if ($is_utf8_locale) {
1651             use locale ':not_characters';
1652             push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1653         }
1654         else {
1655             push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1656         }
1657     }
1658     report_multi_result($Locale, $locales_test_number, \@f);
1659
1660     ++$locales_test_number;
1661     undef @f;
1662     $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1663     for (map { chr } 0..255) {
1664         if ($is_utf8_locale) {
1665             use locale ':not_characters';
1666             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1667         }
1668         else {
1669             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1670         }
1671     }
1672     report_multi_result($Locale, $locales_test_number, \@f);
1673
1674     ++$locales_test_number;
1675     undef @f;
1676     $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1677     for (map { chr } 0..255) {
1678         if ($is_utf8_locale) {
1679             use locale ':not_characters';
1680             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1681         }
1682         else {
1683             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1684         }
1685     }
1686     report_multi_result($Locale, $locales_test_number, \@f);
1687
1688     ++$locales_test_number;
1689     undef @f;
1690     $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1691     for (map { chr } 0..255) {
1692         if ($is_utf8_locale) {
1693             use locale ':not_characters';
1694             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1695         }
1696         else {
1697             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1698         }
1699     }
1700     report_multi_result($Locale, $locales_test_number, \@f);
1701
1702     foreach ($first_casing_test_number..$locales_test_number) {
1703         $problematical_tests{$_} = 1;
1704     }
1705
1706
1707     # Test for read-only scalars' locale vs non-locale comparisons.
1708
1709     {
1710         no locale;
1711         my $ok;
1712         $a = "qwerty";
1713         if ($is_utf8_locale) {
1714             use locale ':not_characters';
1715             $ok = ($a cmp "qwerty") == 0;
1716         }
1717         else {
1718             use locale;
1719             $ok = ($a cmp "qwerty") == 0;
1720         }
1721         report_result($Locale, ++$locales_test_number, $ok);
1722         $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1723     }
1724
1725     {
1726         my ($from, $to, $lesser, $greater,
1727             @test, %test, $test, $yes, $no, $sign);
1728
1729         ++$locales_test_number;
1730         $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1731         $not_necessarily_a_problem_test_number = $locales_test_number;
1732         for (0..9) {
1733             # Select a slice.
1734             $from = int(($_*@{$posixes{'word'}})/10);
1735             $to = $from + int(@{$posixes{'word'}}/10);
1736             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1737             $lesser  = join('', @{$posixes{'word'}}[$from..$to]);
1738             # Select a slice one character on.
1739             $from++; $to++;
1740             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1741             $greater = join('', @{$posixes{'word'}}[$from..$to]);
1742             if ($is_utf8_locale) {
1743                 use locale ':not_characters';
1744                 ($yes, $no, $sign) = ($lesser lt $greater
1745                                     ? ("    ", "not ", 1)
1746                                     : ("not ", "    ", -1));
1747             }
1748             else {
1749                 use locale;
1750                 ($yes, $no, $sign) = ($lesser lt $greater
1751                                     ? ("    ", "not ", 1)
1752                                     : ("not ", "    ", -1));
1753             }
1754             # all these tests should FAIL (return 0).  Exact lt or gt cannot
1755             # be tested because in some locales, say, eacute and E may test
1756             # equal.
1757             @test =
1758                 (
1759                     $no.'    ($lesser  le $greater)',  # 1
1760                     'not      ($lesser  ne $greater)', # 2
1761                     '         ($lesser  eq $greater)', # 3
1762                     $yes.'    ($lesser  ge $greater)', # 4
1763                     $yes.'    ($lesser  ge $greater)', # 5
1764                     $yes.'    ($greater le $lesser )', # 7
1765                     'not      ($greater ne $lesser )', # 8
1766                     '         ($greater eq $lesser )', # 9
1767                     $no.'     ($greater ge $lesser )', # 10
1768                     'not (($lesser cmp $greater) == -($sign))' # 11
1769                     );
1770             @test{@test} = 0 x @test;
1771             $test = 0;
1772             for my $ti (@test) {
1773                 if ($is_utf8_locale) {
1774                     use locale ':not_characters';
1775                     $test{$ti} = eval $ti;
1776                 }
1777                 else {
1778                     # Already in 'use locale';
1779                     $test{$ti} = eval $ti;
1780                 }
1781                 $test ||= $test{$ti}
1782             }
1783             report_result($Locale, $locales_test_number, $test == 0);
1784             if ($test) {
1785                 debug "lesser  = '$lesser'\n";
1786                 debug "greater = '$greater'\n";
1787                 debug "lesser cmp greater = ",
1788                         $lesser cmp $greater, "\n";
1789                 debug "greater cmp lesser = ",
1790                         $greater cmp $lesser, "\n";
1791                 debug "(greater) from = $from, to = $to\n";
1792                 for my $ti (@test) {
1793                     debugf("# %-40s %-4s", $ti,
1794                             $test{$ti} ? 'FAIL' : 'ok');
1795                     if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1796                         debugf("(%s == %4d)", $1, eval $1);
1797                     }
1798                     debugf("\n#");
1799                 }
1800
1801                 last;
1802             }
1803         }
1804
1805         use locale;
1806
1807         my @sorted_controls;
1808
1809         ++$locales_test_number;
1810         $test_names{$locales_test_number}
1811                 = 'Skip in locales where there are no controls;'
1812                 . ' otherwise verify that \0 sorts before any (other) control';
1813         if (! $posixes{'cntrl'}) {
1814             report_result($Locale, $locales_test_number, 1);
1815
1816             # We use all code points for the tests below since there aren't
1817             # any controls
1818             push @sorted_controls, chr $_ for 1..255;
1819             @sorted_controls = sort @sorted_controls;
1820         }
1821         else {
1822             @sorted_controls = @{$posixes{'cntrl'}};
1823             push @sorted_controls, "\0",
1824                                 unless grep { $_ eq "\0" } @sorted_controls;
1825             @sorted_controls = sort @sorted_controls;
1826             my $output = "";
1827             for my $control (@sorted_controls) {
1828                 $output .= " " . disp_chars($control);
1829             }
1830             debug "sorted :cntrl: (plus NUL) = $output\n";
1831             my $ok = $sorted_controls[0] eq "\0";
1832             report_result($Locale, $locales_test_number, $ok);
1833
1834             shift @sorted_controls if $ok;
1835         }
1836
1837         my $lowest_control = $sorted_controls[0];
1838
1839         ++$locales_test_number;
1840         $test_names{$locales_test_number}
1841             = 'Skip in locales where all controls have primary sorting weight; '
1842             . 'otherwise verify that \0 doesn\'t have primary sorting weight';
1843         if ("a${lowest_control}c" lt "ab") {
1844             report_result($Locale, $locales_test_number, 1);
1845         }
1846         else {
1847             my $ok = "ab" lt "a\0c";
1848             report_result($Locale, $locales_test_number, $ok);
1849         }
1850
1851         ++$locales_test_number;
1852         $test_names{$locales_test_number}
1853                             = 'Verify that strings with embedded NUL collate';
1854         my $ok = "a\0a\0a" lt "a${lowest_control}a${lowest_control}a";
1855         report_result($Locale, $locales_test_number, $ok);
1856
1857         ++$locales_test_number;
1858         $test_names{$locales_test_number}
1859                             = 'Verify that strings with embedded NUL and '
1860                             . 'extra trailing NUL collate';
1861         $ok = "a\0a\0" lt "a${lowest_control}a${lowest_control}";
1862         report_result($Locale, $locales_test_number, $ok);
1863
1864         ++$locales_test_number;
1865         $test_names{$locales_test_number}
1866                             = 'Verify that empty strings collate';
1867         $ok = "" le "";
1868         report_result($Locale, $locales_test_number, $ok);
1869
1870         ++$locales_test_number;
1871         $test_names{$locales_test_number}
1872             = "Skip in non-UTF-8 locales; otherwise verify that UTF8ness "
1873             . "doesn't matter with collation";
1874         if (! $is_utf8_locale) {
1875             report_result($Locale, $locales_test_number, 1);
1876         }
1877         else {
1878
1879             # khw can't think of anything better.  Start with a string that is
1880             # higher than its UTF-8 representation in both EBCDIC and ASCII
1881             my $string = chr utf8::unicode_to_native(0xff);
1882             my $utf8_string = $string;
1883             utf8::upgrade($utf8_string);
1884
1885             # 8 should be lt 9 in all locales (except ones that aren't
1886             # ASCII-based, which might fail this)
1887             $ok = ("a${string}8") lt ("a${utf8_string}9");
1888             report_result($Locale, $locales_test_number, $ok);
1889         }
1890
1891         ++$locales_test_number;
1892         $test_names{$locales_test_number}
1893             = "Skip in UTF-8 locales; otherwise verify that single byte "
1894             . "collates before 0x100 and above";
1895         if ($is_utf8_locale) {
1896             report_result($Locale, $locales_test_number, 1);
1897         }
1898         else {
1899             my $max_collating = chr 0;  # Find byte that collates highest
1900             for my $i (0 .. 255) {
1901                 my $char = chr $i;
1902                 $max_collating = $char if $char gt $max_collating;
1903             }
1904             $ok = $max_collating lt chr 0x100;
1905             report_result($Locale, $locales_test_number, $ok);
1906         }
1907
1908         ++$locales_test_number;
1909         $test_names{$locales_test_number}
1910             = "Skip in UTF-8 locales; otherwise verify that 0x100 and "
1911             . "above collate in code point order";
1912         if ($is_utf8_locale) {
1913             report_result($Locale, $locales_test_number, 1);
1914         }
1915         else {
1916             $ok = chr 0x100 lt chr 0x101;
1917             report_result($Locale, $locales_test_number, $ok);
1918         }
1919     }
1920
1921     my $ok1;
1922     my $ok2;
1923     my $ok3;
1924     my $ok4;
1925     my $ok5;
1926     my $ok6;
1927     my $ok7;
1928     my $ok8;
1929     my $ok9;
1930     my $ok10;
1931     my $ok11;
1932     my $ok12;
1933     my $ok13;
1934     my $ok14;
1935     my $ok14_5;
1936     my $ok15;
1937     my $ok16;
1938     my $ok17;
1939     my $ok18;
1940     my $ok19;
1941     my $ok20;
1942     my $ok21;
1943
1944     my $c;
1945     my $d;
1946     my $e;
1947     my $f;
1948     my $g;
1949     my $h;
1950     my $i;
1951     my $j;
1952
1953     if (! $is_utf8_locale) {
1954         use locale;
1955
1956         my ($x, $y) = (1.23, 1.23);
1957
1958         $a = "$x";
1959         printf ''; # printf used to reset locale to "C"
1960         $b = "$y";
1961         $ok1 = $a eq $b;
1962
1963         $c = "$x";
1964         my $z = sprintf ''; # sprintf used to reset locale to "C"
1965         $d = "$y";
1966         $ok2 = $c eq $d;
1967         {
1968
1969             use warnings;
1970             my $w = 0;
1971             local $SIG{__WARN__} =
1972                 sub {
1973                     print "# @_\n";
1974                     $w++;
1975                 };
1976
1977             # The == (among other ops) used to warn for locales
1978             # that had something else than "." as the radix character.
1979
1980             $ok3 = $c == 1.23;
1981             $ok4 = $c == $x;
1982             $ok5 = $c == $d;
1983             {
1984                 no locale;
1985
1986                 $e = "$x";
1987
1988                 $ok6 = $e == 1.23;
1989                 $ok7 = $e == $x;
1990                 $ok8 = $e == $c;
1991             }
1992
1993             $f = "1.23";
1994             $g = 2.34;
1995             $h = 1.5;
1996             $i = 1.25;
1997             $j = "$h:$i";
1998
1999             $ok9 = $f == 1.23;
2000             $ok10 = $f == $x;
2001             $ok11 = $f == $c;
2002             $ok12 = abs(($f + $g) - 3.57) < 0.01;
2003             $ok13 = $w == 0;
2004             $ok14 = $ok14_5 = $ok15 = $ok16 = 1;  # Skip for non-utf8 locales
2005         }
2006         {
2007             no locale;
2008             $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
2009         }
2010         $ok18 = $j eq sprintf("%g:%g", $h, $i);
2011     }
2012     else {
2013         use locale ':not_characters';
2014
2015         my ($x, $y) = (1.23, 1.23);
2016         $a = "$x";
2017         printf ''; # printf used to reset locale to "C"
2018         $b = "$y";
2019         $ok1 = $a eq $b;
2020
2021         $c = "$x";
2022         my $z = sprintf ''; # sprintf used to reset locale to "C"
2023         $d = "$y";
2024         $ok2 = $c eq $d;
2025         {
2026             use warnings;
2027             my $w = 0;
2028             local $SIG{__WARN__} =
2029                 sub {
2030                     print "# @_\n";
2031                     $w++;
2032                 };
2033             $ok3 = $c == 1.23;
2034             $ok4 = $c == $x;
2035             $ok5 = $c == $d;
2036             {
2037                 no locale;
2038                 $e = "$x";
2039
2040                 $ok6 = $e == 1.23;
2041                 $ok7 = $e == $x;
2042                 $ok8 = $e == $c;
2043             }
2044
2045             $f = "1.23";
2046             $g = 2.34;
2047             $h = 1.5;
2048             $i = 1.25;
2049             $j = "$h:$i";
2050
2051             $ok9 = $f == 1.23;
2052             $ok10 = $f == $x;
2053             $ok11 = $f == $c;
2054             $ok12 = abs(($f + $g) - 3.57) < 0.01;
2055             $ok13 = $w == 0;
2056
2057             # Look for non-ASCII error messages, and verify that the first
2058             # such is in UTF-8 (the others almost certainly will be like the
2059             # first).  This is only done if the current locale has LC_MESSAGES
2060             $ok14 = 1;
2061             $ok14_5 = 1;
2062             if (   locales_enabled('LC_MESSAGES')
2063                 && setlocale(&POSIX::LC_MESSAGES, $Locale))
2064             {
2065                 foreach my $err (keys %!) {
2066                     use Errno;
2067                     $! = eval "&Errno::$err";   # Convert to strerror() output
2068                     my $errnum = 0+$!;
2069                     my $strerror = "$!";
2070                     if ("$strerror" =~ /\P{ASCII}/) {
2071                         $ok14 = utf8::is_utf8($strerror);
2072                         no locale;
2073                         $ok14_5 = "$!" !~ /\P{ASCII}/;
2074                         debug( disp_str(
2075                         "non-ASCII \$! for error $errnum='$strerror'"))
2076                                                                    if ! $ok14_5;
2077                         last;
2078                     }
2079                 }
2080             }
2081
2082             # Similarly, we verify that a non-ASCII radix is in UTF-8.  This
2083             # also catches if there is a disparity between sprintf and
2084             # stringification.
2085
2086             my $string_g = "$g";
2087             my $sprintf_g = sprintf("%g", $g);
2088
2089             $ok15 = $string_g =~ / ^ \p{ASCII}+ $ /x || utf8::is_utf8($string_g);
2090             $ok16 = $sprintf_g eq $string_g;
2091         }
2092         {
2093             no locale;
2094             $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
2095         }
2096         $ok18 = $j eq sprintf("%g:%g", $h, $i);
2097     }
2098
2099     $ok19 = $ok20 = 1;
2100     if (setlocale(&POSIX::LC_TIME, $Locale)) { # These tests aren't affected by
2101                                                # :not_characters
2102         my @times = CORE::localtime();
2103
2104         use locale;
2105         $ok19 = POSIX::strftime("%p", @times) ne "%p"; # [perl #119425]
2106         my $date = POSIX::strftime("'%A'  '%B'  '%Z'  '%p'", @times);
2107         debug("'Day' 'Month' 'TZ' 'am/pm' = ", disp_str($date));
2108
2109         # If there is any non-ascii, it better be UTF-8 in a UTF-8 locale, and
2110         # not UTF-8 if the locale isn't UTF-8.
2111         $ok20 = $date =~ / ^ \p{ASCII}+ $ /x
2112                 || $is_utf8_locale == utf8::is_utf8($date);
2113     }
2114
2115     $ok21 = 1;
2116     if (locales_enabled('LC_MESSAGES')) {
2117         foreach my $err (keys %!) {
2118             no locale;
2119             use Errno;
2120             $! = eval "&Errno::$err";   # Convert to strerror() output
2121             my $strerror = "$!";
2122             if ($strerror =~ /\P{ASCII}/) {
2123                 $ok21 = 0;
2124                 debug(disp_str("non-ASCII strerror=$strerror"));
2125                 last;
2126             }
2127         }
2128     }
2129
2130     report_result($Locale, ++$locales_test_number, $ok1);
2131     $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
2132     my $first_a_test = $locales_test_number;
2133
2134     debug "$first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
2135
2136     report_result($Locale, ++$locales_test_number, $ok2);
2137     $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
2138
2139     my $first_c_test = $locales_test_number;
2140
2141     $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
2142     if ($Config{usequadmath}) {
2143         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2144         report_result($Locale, $locales_test_number, 1);
2145     } else {
2146         report_result($Locale, $locales_test_number, $ok3);
2147         $problematical_tests{$locales_test_number} = 1;
2148     }
2149
2150     $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
2151     if ($Config{usequadmath}) {
2152         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2153         report_result($Locale, $locales_test_number, 1);
2154     } else {
2155         report_result($Locale, $locales_test_number, $ok4);
2156         $problematical_tests{$locales_test_number} = 1;
2157     }
2158
2159     report_result($Locale, ++$locales_test_number, $ok5);
2160     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
2161     $problematical_tests{$locales_test_number} = 1;
2162
2163     debug "$first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
2164
2165     report_result($Locale, ++$locales_test_number, $ok6);
2166     $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
2167     my $first_e_test = $locales_test_number;
2168
2169     report_result($Locale, ++$locales_test_number, $ok7);
2170     $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
2171
2172     $test_names{++$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
2173     if ($Config{usequadmath}) {
2174         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2175         report_result($Locale, $locales_test_number, 1);
2176     } else {
2177         report_result($Locale, $locales_test_number, $ok8);
2178         $problematical_tests{$locales_test_number} = 1;
2179     }
2180
2181     debug "$first_e_test..$locales_test_number: \$e = $e, no locale\n";
2182
2183     report_result($Locale, ++$locales_test_number, $ok9);
2184     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
2185     $problematical_tests{$locales_test_number} = 1;
2186     my $first_f_test = $locales_test_number;
2187
2188     report_result($Locale, ++$locales_test_number, $ok10);
2189     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
2190     $problematical_tests{$locales_test_number} = 1;
2191
2192     $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';
2193     if ($Config{usequadmath}) {
2194         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2195         report_result($Locale, $locales_test_number, 1);
2196     } else {
2197         report_result($Locale, $locales_test_number, $ok11);
2198         $problematical_tests{$locales_test_number} = 1;
2199     }
2200
2201     report_result($Locale, ++$locales_test_number, $ok12);
2202     $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';
2203     $problematical_tests{$locales_test_number} = 1;
2204
2205     report_result($Locale, ++$locales_test_number, $ok13);
2206     $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
2207     $problematical_tests{$locales_test_number} = 1;
2208
2209     report_result($Locale, ++$locales_test_number, $ok14);
2210     $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
2211
2212     report_result($Locale, ++$locales_test_number, $ok14_5);
2213     $test_names{$locales_test_number} = '... and are ASCII outside "use locale"';
2214
2215     report_result($Locale, ++$locales_test_number, $ok15);
2216     $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
2217
2218     report_result($Locale, ++$locales_test_number, $ok16);
2219     $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
2220     $problematical_tests{$locales_test_number} = 1;
2221
2222     report_result($Locale, ++$locales_test_number, $ok17);
2223     $test_names{$locales_test_number} = 'Verify that a sprintf of a number outside locale scope uses a dot radix';
2224
2225     report_result($Locale, ++$locales_test_number, $ok18);
2226     $test_names{$locales_test_number} = 'Verify that a sprintf of a number back within locale scope uses locale radix';
2227     $problematical_tests{$locales_test_number} = 1;
2228
2229     report_result($Locale, ++$locales_test_number, $ok19);
2230     $test_names{$locales_test_number} = 'Verify that strftime doesn\'t return "%p" in locales where %p is empty';
2231
2232     report_result($Locale, ++$locales_test_number, $ok20);
2233     $test_names{$locales_test_number} = 'Verify that strftime returns date with UTF-8 flag appropriately set';
2234     $problematical_tests{$locales_test_number} = 1;   # This is broken in
2235                                                       # OS X 10.9.3
2236
2237     report_result($Locale, ++$locales_test_number, $ok21);
2238     $test_names{$locales_test_number} = '"$!" is ASCII only outside of locale scope';
2239
2240     debug "$first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
2241
2242     # Does taking lc separately differ from taking
2243     # the lc "in-line"?  (This was the bug 19990704.002 (#965), change #3568.)
2244     # The bug was in the caching of the 'o'-magic.
2245     if (! $is_utf8_locale) {
2246         use locale;
2247
2248         sub lcA {
2249             my $lc0 = lc $_[0];
2250             my $lc1 = lc $_[1];
2251             return $lc0 cmp $lc1;
2252         }
2253
2254         sub lcB {
2255             return lc($_[0]) cmp lc($_[1]);
2256         }
2257
2258         my $x = "ab";
2259         my $y = "aa";
2260         my $z = "AB";
2261
2262         report_result($Locale, ++$locales_test_number,
2263                     lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
2264                     lcA($x, $z) == 0 && lcB($x, $z) == 0);
2265     }
2266     else {
2267         use locale ':not_characters';
2268
2269         sub lcC {
2270             my $lc0 = lc $_[0];
2271             my $lc1 = lc $_[1];
2272             return $lc0 cmp $lc1;
2273         }
2274
2275         sub lcD {
2276             return lc($_[0]) cmp lc($_[1]);
2277         }
2278
2279         my $x = "ab";
2280         my $y = "aa";
2281         my $z = "AB";
2282
2283         report_result($Locale, ++$locales_test_number,
2284                     lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
2285                     lcC($x, $z) == 0 && lcD($x, $z) == 0);
2286     }
2287     $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
2288
2289     # Does lc of an UPPER (if different from the UPPER) match
2290     # case-insensitively the UPPER, and does the UPPER match
2291     # case-insensitively the lc of the UPPER.  And vice versa.
2292     {
2293         use locale;
2294         no utf8;
2295         my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
2296
2297         my @f = ();
2298         ++$locales_test_number;
2299         $test_names{$locales_test_number} = 'Verify case insensitive matching works';
2300         foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
2301             if (! $is_utf8_locale) {
2302                 my $y = lc $x;
2303                 next unless uc $y eq $x;
2304                 debug_more( "UPPER=", disp_chars(($x)),
2305                             "; lc=", disp_chars(($y)), "; ",
2306                             "; fc=", disp_chars((fc $x)), "; ",
2307                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2308                             $x =~ /\Q$y/i ? 1 : 0,
2309                             "; ",
2310                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2311                             $y =~ /\Q$x/i ? 1 : 0,
2312                             "\n");
2313                 #
2314                 # If $x and $y contain regular expression characters
2315                 # AND THEY lowercase (/i) to regular expression characters,
2316                 # regcomp() will be mightily confused.  No, the \Q doesn't
2317                 # help here (maybe regex engine internal lowercasing
2318                 # is done after the \Q?)  An example of this happening is
2319                 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
2320                 # the chr(173) (the "[") is the lowercase of the chr(235).
2321                 #
2322                 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
2323                 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
2324                 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
2325                 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
2326                 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
2327                 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
2328                 #
2329                 # Similar things can happen even under (bastardised)
2330                 # non-EBCDIC locales: in many European countries before the
2331                 # advent of ISO 8859-x nationally customised versions of
2332                 # ISO 646 were devised, reusing certain punctuation
2333                 # characters for modified characters needed by the
2334                 # country/language.  For example, the "|" might have
2335                 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
2336                 #
2337                 if ($x =~ $re || $y =~ $re) {
2338                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2339                     next;
2340                 }
2341                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2342
2343                 # fc is not a locale concept, so Perl uses lc for it.
2344                 push @f, $x unless lc $x eq fc $x;
2345             }
2346             else {
2347                 use locale ':not_characters';
2348                 my $y = lc $x;
2349                 next unless uc $y eq $x;
2350                 debug_more( "UPPER=", disp_chars(($x)),
2351                             "; lc=", disp_chars(($y)), "; ",
2352                             "; fc=", disp_chars((fc $x)), "; ",
2353                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2354                             $x =~ /\Q$y/i ? 1 : 0,
2355                             "; ",
2356                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2357                             $y =~ /\Q$x/i ? 1 : 0,
2358                             "\n");
2359
2360                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2361
2362                 # The places where Unicode's lc is different from fc are
2363                 # skipped here by virtue of the 'next unless uc...' line above
2364                 push @f, $x unless lc $x eq fc $x;
2365             }
2366         }
2367
2368         foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
2369             if (! $is_utf8_locale) {
2370                 my $y = uc $x;
2371                 next unless lc $y eq $x;
2372                 debug_more( "lower=", disp_chars(($x)),
2373                             "; uc=", disp_chars(($y)), "; ",
2374                             "; fc=", disp_chars((fc $x)), "; ",
2375                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2376                             $x =~ /\Q$y/i ? 1 : 0,
2377                             "; ",
2378                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2379                             $y =~ /\Q$x/i ? 1 : 0,
2380                             "\n");
2381                 if ($x =~ $re || $y =~ $re) { # See above.
2382                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2383                     next;
2384                 }
2385                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2386
2387                 push @f, $x unless lc $x eq fc $x;
2388             }
2389             else {
2390                 use locale ':not_characters';
2391                 my $y = uc $x;
2392                 next unless lc $y eq $x;
2393                 debug_more( "lower=", disp_chars(($x)),
2394                             "; uc=", disp_chars(($y)), "; ",
2395                             "; fc=", disp_chars((fc $x)), "; ",
2396                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2397                             $x =~ /\Q$y/i ? 1 : 0,
2398                             "; ",
2399                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2400                             $y =~ /\Q$x/i ? 1 : 0,
2401                             "\n");
2402                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2403
2404                 push @f, $x unless lc $x eq fc $x;
2405             }
2406         }
2407         report_multi_result($Locale, $locales_test_number, \@f);
2408         $problematical_tests{$locales_test_number} = 1;
2409     }
2410
2411     # [perl #109318]
2412     {
2413         my @f = ();
2414         ++$locales_test_number;
2415         $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
2416         $problematical_tests{$locales_test_number} = 1;
2417
2418         my $radix = POSIX::localeconv()->{decimal_point};
2419         my @nums = (
2420              "3.14e+9",  "3${radix}14e+9",  "3.14e-9",  "3${radix}14e-9",
2421             "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
2422         );
2423
2424         if (! $is_utf8_locale) {
2425             use locale;
2426             for my $num (@nums) {
2427                 push @f, $num
2428                     unless sprintf("%g", $num) =~ /3.+14/;
2429             }
2430         }
2431         else {
2432             use locale ':not_characters';
2433             for my $num (@nums) {
2434                 push @f, $num
2435                     unless sprintf("%g", $num) =~ /3.+14/;
2436             }
2437         }
2438
2439         if ($Config{usequadmath}) {
2440             print "# Skip: no locale radix with usequadmath ($Locale)\n";
2441             report_result($Locale, $locales_test_number, 1);
2442         } else {
2443             report_result($Locale, $locales_test_number, @f == 0);
2444             if (@f) {
2445                 print "# failed $locales_test_number locale '$Locale' numbers @f\n"
2446             }
2447         }
2448     }
2449 }
2450
2451 my $final_locales_test_number = $locales_test_number;
2452
2453 # Recount the errors.
2454
2455 TEST_NUM:
2456 foreach $test_num ($first_locales_test_number..$final_locales_test_number) {
2457     my $has_non_global_failure = $Problem{$test_num}
2458                             || ! defined $Okay{$test_num}
2459                             || ! @{$Okay{$test_num}};
2460     print "not " if %setlocale_failed || $has_non_global_failure;
2461     print "ok $test_num";
2462     $test_names{$test_num} = "" unless defined $test_names{$test_num};
2463
2464     # If TODO is in the test name, make it thus
2465     my $todo = $test_names{$test_num} =~ s/\s*TODO\s*//;
2466     print " $test_names{$test_num}";
2467     if ($todo) {
2468         print " # TODO\n";
2469     }
2470     elsif (%setlocale_failed || ! $has_non_global_failure) {
2471         print "\n";
2472     }
2473     elsif ($has_non_global_failure) {
2474
2475         # If there are any locales that pass this test, or are known-bad, it
2476         # may be that there are enough passes that we TODO the failure, but
2477         # only for tests that we have decided can be problematical.
2478         if (  ($Okay{$test_num} || $Known_bad_locale{$test_num})
2479             && grep { $_ == $test_num } keys %problematical_tests)
2480         {
2481             # Don't count the known-bad failures when calculating the
2482             # percentage that fail.
2483             my $known_failures = (exists $Known_bad_locale{$test_num})
2484                                   ? scalar(keys $Known_bad_locale{$test_num}->%*)
2485                                   : 0;
2486             my $adjusted_failures = scalar(keys $Problem{$test_num}->%*)
2487                                     - $known_failures;
2488
2489             # Specially handle failures where only known-bad locales fail.
2490             # This makes the diagnositics clearer.
2491             if ($adjusted_failures <= 0) {
2492                 print " # TODO fails only on known bad locales: ",
2493                       join " ", keys $Known_bad_locale{$test_num}->%*, "\n";
2494                 next TEST_NUM;
2495             }
2496
2497             # Round to nearest .1%
2498             my $percent_fail = (int(.5 + (1000 * $adjusted_failures
2499                                           / scalar(@Locale))))
2500                                / 10;
2501             $todo = $percent_fail < $acceptable_failure_percentage;
2502             print " # TODO" if $todo;
2503             print "\n";
2504
2505             if ($debug) {
2506                 print "# $percent_fail% of locales (",
2507                       scalar(keys $Problem{$test_num}->%*),
2508                       " of ",
2509                       scalar(@Locale),
2510                       ") fail the above test (TODO cut-off is ",
2511                       $acceptable_failure_percentage,
2512                       "%)\n";
2513             }
2514             elsif ($todo) {
2515                 print "# ", 100 - $percent_fail, "% of locales not known to be problematic on this platform\n";
2516                 print "# pass the above test, so it is likely that the failures\n";
2517                 print "# are errors in the locale definitions.  The test is marked TODO, as the\n";
2518                 print "# problem is not likely to be Perl's\n";
2519             }
2520         }
2521
2522         if ($debug) {
2523             print "# The code points that had this failure are given above.  Look for lines\n";
2524             print "# that match 'failed $test_num'\n";
2525         }
2526         else {
2527             print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2528             print "# Then look at that output for lines that match 'failed $test_num'\n";
2529         }
2530         if (defined $not_necessarily_a_problem_test_number
2531             && $test_num == $not_necessarily_a_problem_test_number)
2532         {
2533             print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
2534             print "# It usually indicates a problem in the environment,\n";
2535             print "# not in Perl itself.\n";
2536         }
2537     }
2538 }
2539
2540 $test_num = $final_locales_test_number;
2541
2542 unless ( $^O =~ m!^(dragonfly|openbsd|bitrig|mirbsd)$! ) {
2543     # perl #115808
2544     use warnings;
2545     my $warned = 0;
2546     local $SIG{__WARN__} = sub {
2547         $warned = $_[0] =~ /uninitialized/;
2548     };
2549     my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
2550     ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
2551 }
2552
2553 # Test that tainting and case changing works on utf8 strings.  These tests are
2554 # placed last to avoid disturbing the hard-coded test numbers that existed at
2555 # the time these were added above this in this file.
2556 # This also tests that locale overrides unicode_strings in the same scope for
2557 # non-utf8 strings.
2558 setlocale(&POSIX::LC_ALL, "C");
2559 {
2560     use locale;
2561     use feature 'unicode_strings';
2562
2563     foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
2564         my @list;   # List of code points to test for $function
2565
2566         # Used to calculate the changed case for ASCII characters by using the
2567         # ord, instead of using one of the functions under test.
2568         my $ascii_case_change_delta;
2569         my $above_latin1_case_change_delta; # Same for the specific ords > 255
2570                                             # that we use
2571
2572         # We test an ASCII character, which should change case;
2573         # a Latin1 character, which shouldn't change case under this C locale,
2574         # an above-Latin1 character that when the case is changed would cross
2575         #   the 255/256 boundary, so doesn't change case
2576         #   (the \x{149} is one of these, but changes into 2 characters, the
2577         #   first one of which doesn't cross the boundary.
2578         # the final one in each list is an above-Latin1 character whose case
2579         #   does change.  The code below uses its position in its list as a
2580         #   marker to indicate that it, unlike the other code points above
2581         #   ASCII, has a successful case change
2582         #
2583         # All casing operations under locale (but not :not_characters) should
2584         # taint
2585         if ($function =~ /^u/) {
2586             @list = ("", "a",
2587                      chr(utf8::unicode_to_native(0xe0)),
2588                      chr(utf8::unicode_to_native(0xff)),
2589                      "\x{fb00}", "\x{149}", "\x{101}");
2590             $ascii_case_change_delta = ($is_ebcdic) ? +64 : -32;
2591             $above_latin1_case_change_delta = -1;
2592         }
2593         else {
2594             @list = ("", "A",
2595                      chr(utf8::unicode_to_native(0xC0)),
2596                      "\x{17F}", "\x{100}");
2597             $ascii_case_change_delta = ($is_ebcdic) ? -64 : +32;
2598             $above_latin1_case_change_delta = +1;
2599         }
2600         foreach my $is_utf8_locale (0 .. 1) {
2601             foreach my $j (0 .. $#list) {
2602                 my $char = $list[$j];
2603
2604                 for my $encoded_in_utf8 (0 .. 1) {
2605                     my $should_be;
2606                     my $changed;
2607                     if (! $is_utf8_locale) {
2608                         no warnings 'locale';
2609                         $should_be = ($j == $#list)
2610                             ? chr(ord($char) + $above_latin1_case_change_delta)
2611                             : (length $char == 0 || utf8::native_to_unicode(ord($char)) > 127)
2612                               ? $char
2613                               : chr(ord($char) + $ascii_case_change_delta);
2614
2615                         # This monstrosity is in order to avoid using an eval,
2616                         # which might perturb the results
2617                         $changed = ($function eq "uc")
2618                                     ? uc($char)
2619                                     : ($function eq "ucfirst")
2620                                       ? ucfirst($char)
2621                                       : ($function eq "lc")
2622                                         ? lc($char)
2623                                         : ($function eq "lcfirst")
2624                                           ? lcfirst($char)
2625                                           : ($function eq "fc")
2626                                             ? fc($char)
2627                                             : die("Unexpected function \"$function\"");
2628                     }
2629                     else {
2630                         {
2631                             no locale;
2632
2633                             # For utf8-locales the case changing functions
2634                             # should work just like they do outside of locale.
2635                             # Can use eval here because not testing it when
2636                             # not in locale.
2637                             $should_be = eval "$function('$char')";
2638                             die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if  $@;
2639
2640                         }
2641                         use locale ':not_characters';
2642                         $changed = ($function eq "uc")
2643                                     ? uc($char)
2644                                     : ($function eq "ucfirst")
2645                                       ? ucfirst($char)
2646                                       : ($function eq "lc")
2647                                         ? lc($char)
2648                                         : ($function eq "lcfirst")
2649                                           ? lcfirst($char)
2650                                           : ($function eq "fc")
2651                                             ? fc($char)
2652                                             : die("Unexpected function \"$function\"");
2653                     }
2654                     ok($changed eq $should_be,
2655                         "$function(\"$char\") in C locale "
2656                         . (($is_utf8_locale)
2657                             ? "(use locale ':not_characters'"
2658                             : "(use locale")
2659                         . (($encoded_in_utf8)
2660                             ? "; encoded in utf8)"
2661                             : "; not encoded in utf8)")
2662                         . " should be \"$should_be\", got \"$changed\"");
2663
2664                     # Tainting shouldn't happen for use locale :not_character
2665                     # (a utf8 locale)
2666                     (! $is_utf8_locale)
2667                     ? check_taint($changed)
2668                     : check_taint_not($changed);
2669
2670                     # Use UTF-8 next time through the loop
2671                     utf8::upgrade($char);
2672                 }
2673             }
2674         }
2675     }
2676 }
2677
2678 # Give final advice.
2679
2680 my $didwarn = 0;
2681
2682 foreach ($first_locales_test_number..$final_locales_test_number) {
2683     if ($Problem{$_}) {
2684         my @f = sort keys %{ $Problem{$_} };
2685
2686         # Don't list the failures caused by known-bad locales.
2687         if (exists $known_bad_locales{$^O}) {
2688             @f = grep { $_ !~ $known_bad_locales{$^O} } @f;
2689             next unless @f;
2690         }
2691         my $f = join(" ", @f);
2692         $f =~ s/(.{50,60}) /$1\n#\t/g;
2693         print
2694             "#\n",
2695             "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
2696             "#\t", $f, "\n#\n",
2697             "# on your system may have errors because the locale test $_\n",
2698             "# \"$test_names{$_}\"\n",
2699             "# failed in ", (@f == 1 ? "that locale" : "those locales"),
2700             ".\n";
2701         print <<EOW;
2702 #
2703 # If your users are not using these locales you are safe for the moment,
2704 # but please report this failure first to perlbug\@perl.org using the
2705 # perlbug script (as described in the INSTALL file) so that the exact
2706 # details of the failures can be sorted out first and then your operating
2707 # system supplier can be alerted about these anomalies.
2708 #
2709 EOW
2710         $didwarn = 1;
2711     }
2712 }
2713
2714 # Tell which locales were okay and which were not.
2715
2716 if ($didwarn) {
2717     my (@s, @F);
2718
2719     foreach my $l (@Locale) {
2720         my $p = 0;
2721         if ($setlocale_failed{$l}) {
2722             $p++;
2723         }
2724         else {
2725             foreach my $t
2726                         ($first_locales_test_number..$final_locales_test_number)
2727             {
2728                 $p++ if $Problem{$t}{$l};
2729             }
2730         }
2731         push @s, $l if $p == 0;
2732         push @F, $l unless $p == 0;
2733     }
2734
2735     if (@s) {
2736         my $s = join(" ", @s);
2737         $s =~ s/(.{50,60}) /$1\n#\t/g;
2738
2739         print
2740             "# The following locales\n#\n",
2741             "#\t", $s, "\n#\n",
2742             "# tested okay.\n#\n",
2743     } else {
2744         print "# None of your locales were fully okay.\n";
2745     }
2746
2747     if (@F) {
2748         my $F = join(" ", @F);
2749         $F =~ s/(.{50,60}) /$1\n#\t/g;
2750
2751         my $details = "";
2752         unless ($debug) {
2753             $details = "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2754         }
2755         elsif ($debug == 1) {
2756             $details = "# For even more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=2.\n";
2757         }
2758
2759         print
2760           "# The following locales\n#\n",
2761           "#\t", $F, "\n#\n",
2762           "# had problems.\n#\n",
2763           $details;
2764     } else {
2765         print "# None of your locales were broken.\n";
2766     }
2767 }
2768
2769 if (exists $known_bad_locales{$^O} && ! %Known_bad_locale) {
2770     $test_num++;
2771     print "ok $test_num $^O no longer has known bad locales # TODO\n";
2772 }
2773
2774 print "1..$test_num\n";
2775
2776 # eof