Remove directory depth check from configure.com.
[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', 'postderef';
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 my @Locale = find_locales($categories);
759 my @include_incompatible_locales = find_locales($categories,
760                                                 'even incompatible locales');
761
762 # The locales included in the incompatible list that aren't in the compatible
763 # one.
764 my @incompatible_locales;
765
766 if (@Locale < @include_incompatible_locales) {
767     my %seen;
768     @seen{@Locale} = ();
769
770     foreach my $item (@include_incompatible_locales) {
771         push @incompatible_locales, $item unless exists $seen{$item};
772     }
773
774     # For each bad locale, switch into it to find out why it's incompatible
775     for my $bad_locale (@incompatible_locales) {
776         my @warnings;
777
778         use warnings 'locale';
779
780         local $SIG{__WARN__} = sub {
781             my $warning = $_[0];
782             chomp $warning;
783             push @warnings, ($warning =~ s/\n/\n# /sgr);
784         };
785
786         my $ret = setlocale(&POSIX::LC_CTYPE, $bad_locale);
787
788         my $message = "testing of locale '$bad_locale' is skipped";
789         if (@warnings) {
790             skip $message . ":\n# " . join "\n# ", @warnings;
791         }
792         elsif (! $ret) {
793             skip("$message:\n#"
794                . " setlocale(&POSIX::LC_CTYPE, '$bad_locale') failed");
795         }
796         else {
797             fail $message . ", because it is was found to be incompatible with"
798                           . " Perl, but could not discern reason";
799         }
800     }
801 }
802
803 debug "Locales =\n";
804 for ( @Locale ) {
805     debug "$_\n";
806 }
807
808 unless (@Locale) {
809     print "1..$test_num\n";
810     exit;
811 }
812
813
814 setlocale(&POSIX::LC_ALL, "C");
815
816 my %posixes;
817
818 my %Problem;
819 my %Okay;
820 my %Known_bad_locale;   # Failed test for a locale known to be bad
821 my %Testing;
822 my @Added_alpha;   # Alphas that aren't in the C locale.
823 my %test_names;
824
825 sub disp_chars {
826     # This returns a display string denoting the input parameter @_, each
827     # entry of which is a single character in the range 0-255.  The first part
828     # of the output is a string of the characters in @_ that are ASCII
829     # graphics, and hence unambiguously displayable.  They are given by code
830     # point order.  The second part is the remaining code points, the ordinals
831     # of which are each displayed as 2-digit hex.  Blanks are inserted so as
832     # to keep anything from the first part looking like a 2-digit hex number.
833
834     no locale;
835     my @chars = sort { ord $a <=> ord $b } @_;
836     my $output = "";
837     my $range_start;
838     my $start_class;
839     push @chars, chr(258);  # This sentinel simplifies the loop termination
840                             # logic
841     foreach my $i (0 .. @chars - 1) {
842         my $char = $chars[$i];
843         my $range_end;
844         my $class;
845
846         # We avoid using [:posix:] classes, as these are being tested in this
847         # file.  Each equivalence class below is for things that can appear in
848         # a range; those that can't be in a range have class -1.  0 for those
849         # which should be output in hex; and >0 for the other ranges
850         if ($char =~ /[A-Z]/) {
851             $class = 2;
852         }
853         elsif ($char =~ /[a-z]/) {
854             $class = 3;
855         }
856         elsif ($char =~ /[0-9]/) {
857             $class = 4;
858         }
859         # Uncomment to get literal punctuation displayed instead of hex
860         #elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
861         #    $class = -1;    # Punct never appears in a range
862         #}
863         else {
864             $class = 0;     # Output in hex
865         }
866
867         if (! defined $range_start) {
868             if ($class < 0) {
869                 $output .= " " . $char;
870             }
871             else {
872                 $range_start = ord $char;
873                 $start_class = $class;
874             }
875         } # A range ends if not consecutive, or the class-type changes
876         elsif (ord $char != ($range_end = ord($chars[$i-1])) + 1
877               || $class != $start_class)
878         {
879
880             # Here, the current character is not in the range.  This means the
881             # previous character must have been.  Output the range up through
882             # that one.
883             my $range_length = $range_end - $range_start + 1;
884             if ($start_class > 0) {
885                 $output .= " " . chr($range_start);
886                 $output .= "-" . chr($range_end) if $range_length > 1;
887             }
888             else {
889                 $output .= sprintf(" %02X", $range_start);
890                 $output .= sprintf("-%02X", $range_end) if $range_length > 1;
891             }
892
893             # Handle the new current character, as potentially beginning a new
894             # range
895             undef $range_start;
896             redo;
897         }
898     }
899
900     $output =~ s/^ //;
901     return $output;
902 }
903
904 sub disp_str ($) {
905     my $string = shift;
906
907     # Displays the string unambiguously.  ASCII printables are always output
908     # as-is, though perhaps separated by blanks from other characters.  If
909     # entirely printable ASCII, just returns the string.  Otherwise if valid
910     # UTF-8 it uses the character names for non-printable-ASCII.  Otherwise it
911     # outputs hex for each non-ASCII-printable byte.
912
913     return $string if $string =~ / ^ [[:print:]]* $/xa;
914
915     my $result = "";
916     my $prev_was_punct = 1; # Beginning is considered punct
917     if (utf8::valid($string) && utf8::is_utf8($string)) {
918         use charnames ();
919         foreach my $char (split "", $string) {
920
921             # Keep punctuation adjacent to other characters; otherwise
922             # separate them with a blank
923             if ($char =~ /[[:punct:]]/a) {
924                 $result .= $char;
925                 $prev_was_punct = 1;
926             }
927             elsif ($char =~ /[[:print:]]/a) {
928                 $result .= "  " unless $prev_was_punct;
929                 $result .= $char;
930                 $prev_was_punct = 0;
931             }
932             else {
933                 $result .= "  " unless $prev_was_punct;
934                 my $name = charnames::viacode(ord $char);
935                 $result .= (defined $name) ? $name : ':unknown:';
936                 $prev_was_punct = 0;
937             }
938         }
939     }
940     else {
941         use bytes;
942         foreach my $char (split "", $string) {
943             if ($char =~ /[[:punct:]]/a) {
944                 $result .= $char;
945                 $prev_was_punct = 1;
946             }
947             elsif ($char =~ /[[:print:]]/a) {
948                 $result .= " " unless $prev_was_punct;
949                 $result .= $char;
950                 $prev_was_punct = 0;
951             }
952             else {
953                 $result .= " " unless $prev_was_punct;
954                 $result .= sprintf("%02X", ord $char);
955                 $prev_was_punct = 0;
956             }
957         }
958     }
959
960     return $result;
961 }
962
963 sub report_result {
964     my ($Locale, $i, $pass_fail, $message) = @_;
965     if ($pass_fail) {
966         push @{$Okay{$i}}, $Locale;
967     }
968     else {
969         $message //= "";
970         $message = "  ($message)" if $message;
971         $Known_bad_locale{$i}{$Locale} = 1 if exists $known_bad_locales{$^O}
972                                          && $Locale =~ $known_bad_locales{$^O};
973         $Problem{$i}{$Locale} = 1;
974         debug "failed $i ($test_names{$i}) with locale '$Locale'$message\n";
975     }
976 }
977
978 sub report_multi_result {
979     my ($Locale, $i, $results_ref) = @_;
980
981     # $results_ref points to an array, each element of which is a character that was
982     # in error for this test numbered '$i'.  If empty, the test passed
983
984     my $message = "";
985     if (@$results_ref) {
986         $message = join " ", "for", disp_chars(@$results_ref);
987     }
988     report_result($Locale, $i, @$results_ref == 0, $message);
989 }
990
991 my $first_locales_test_number = $final_without_setlocale
992                               + 1 + @incompatible_locales;
993 my $locales_test_number;
994 my $not_necessarily_a_problem_test_number;
995 my $first_casing_test_number;
996 my %setlocale_failed;   # List of locales that setlocale() didn't work on
997
998 foreach my $Locale (@Locale) {
999     $locales_test_number = $first_locales_test_number - 1;
1000     debug "\n";
1001     debug "Locale = $Locale\n";
1002
1003     unless (setlocale(&POSIX::LC_ALL, $Locale)) {
1004         $setlocale_failed{$Locale} = $Locale;
1005         next;
1006     }
1007
1008     # We test UTF-8 locales only under ':not_characters';  It is easier to
1009     # test them in other test files than here.  Non- UTF-8 locales are tested
1010     # only under plain 'use locale', as otherwise we would have to convert
1011     # everything in them to Unicode.
1012
1013     my %UPPER = ();     # All alpha X for which uc(X) == X and lc(X) != X
1014     my %lower = ();     # All alpha X for which lc(X) == X and uc(X) != X
1015     my %BoThCaSe = ();  # All alpha X for which uc(X) == lc(X) == X
1016
1017     my $is_utf8_locale = is_locale_utf8($Locale);
1018
1019     debug "is utf8 locale? = $is_utf8_locale\n";
1020
1021     debug "radix = " . disp_str(localeconv()->{decimal_point}) . "\n";
1022
1023     if (! $is_utf8_locale) {
1024         use locale;
1025         @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
1026         @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
1027         @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
1028         @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
1029         @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
1030         @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
1031         @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
1032         @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
1033         @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
1034         @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
1035         @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
1036         @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
1037         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
1038         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
1039         @{$posixes{'cased'}} = grep /[[:upper:][:lower:]]/i, map {chr } 0..255;
1040
1041         # Sieve the uppercase and the lowercase.
1042
1043         for (@{$posixes{'word'}}) {
1044             if (/[^\d_]/) { # skip digits and the _
1045                 if (uc($_) eq $_) {
1046                     $UPPER{$_} = $_;
1047                 }
1048                 if (lc($_) eq $_) {
1049                     $lower{$_} = $_;
1050                 }
1051             }
1052         }
1053     }
1054     else {
1055         use locale ':not_characters';
1056         @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
1057         @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
1058         @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
1059         @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
1060         @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
1061         @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
1062         @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
1063         @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
1064         @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
1065         @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
1066         @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
1067         @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
1068         @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
1069         @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
1070         @{$posixes{'cased'}} = grep /[[:upper:][:lower:]]/i, map {chr } 0..255;
1071         for (@{$posixes{'word'}}) {
1072             if (/[^\d_]/) { # skip digits and the _
1073                 if (uc($_) eq $_) {
1074                     $UPPER{$_} = $_;
1075                 }
1076                 if (lc($_) eq $_) {
1077                     $lower{$_} = $_;
1078                 }
1079             }
1080         }
1081     }
1082
1083     # Ordered, where possible,  in groups of "this is a subset of the next
1084     # one"
1085     debug ":upper:  = ", disp_chars(@{$posixes{'upper'}}), "\n";
1086     debug ":lower:  = ", disp_chars(@{$posixes{'lower'}}), "\n";
1087     debug ":cased:  = ", disp_chars(@{$posixes{'cased'}}), "\n";
1088     debug ":alpha:  = ", disp_chars(@{$posixes{'alpha'}}), "\n";
1089     debug ":alnum:  = ", disp_chars(@{$posixes{'alnum'}}), "\n";
1090     debug ' \w      = ', disp_chars(@{$posixes{'word'}}), "\n";
1091     debug ":graph:  = ", disp_chars(@{$posixes{'graph'}}), "\n";
1092     debug ":print:  = ", disp_chars(@{$posixes{'print'}}), "\n";
1093     debug ' \d      = ', disp_chars(@{$posixes{'digit'}}), "\n";
1094     debug ":xdigit: = ", disp_chars(@{$posixes{'xdigit'}}), "\n";
1095     debug ":blank:  = ", disp_chars(@{$posixes{'blank'}}), "\n";
1096     debug ' \s      = ', disp_chars(@{$posixes{'space'}}), "\n";
1097     debug ":punct:  = ", disp_chars(@{$posixes{'punct'}}), "\n";
1098     debug ":cntrl:  = ", disp_chars(@{$posixes{'cntrl'}}), "\n";
1099     debug ":ascii:  = ", disp_chars(@{$posixes{'ascii'}}), "\n";
1100
1101     foreach (keys %UPPER) {
1102
1103         $BoThCaSe{$_}++ if exists $lower{$_};
1104     }
1105     foreach (keys %lower) {
1106         $BoThCaSe{$_}++ if exists $UPPER{$_};
1107     }
1108     foreach (keys %BoThCaSe) {
1109         delete $UPPER{$_};
1110         delete $lower{$_};
1111     }
1112
1113     my %Unassigned;
1114     foreach my $ord ( 0 .. 255 ) {
1115         $Unassigned{chr $ord} = 1;
1116     }
1117     foreach my $class (keys %posixes) {
1118         foreach my $char (@{$posixes{$class}}) {
1119             delete $Unassigned{$char};
1120         }
1121     }
1122
1123     debug "UPPER    = ", disp_chars(sort { ord $a <=> ord $b } keys %UPPER), "\n";
1124     debug "lower    = ", disp_chars(sort { ord $a <=> ord $b } keys %lower), "\n";
1125     debug "BoThCaSe = ", disp_chars(sort { ord $a <=> ord $b } keys %BoThCaSe), "\n";
1126     debug "Unassigned = ", disp_chars(sort { ord $a <=> ord $b } keys %Unassigned), "\n";
1127
1128     my @failures;
1129     my @fold_failures;
1130     foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
1131         my $ok;
1132         my $fold_ok;
1133         if ($is_utf8_locale) {
1134             use locale ':not_characters';
1135             $ok = $x =~ /[[:upper:]]/;
1136             $fold_ok = $x =~ /[[:lower:]]/i;
1137         }
1138         else {
1139             use locale;
1140             $ok = $x =~ /[[:upper:]]/;
1141             $fold_ok = $x =~ /[[:lower:]]/i;
1142         }
1143         push @failures, $x unless $ok;
1144         push @fold_failures, $x unless $fold_ok;
1145     }
1146     $locales_test_number++;
1147     $first_casing_test_number = $locales_test_number;
1148     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
1149     report_multi_result($Locale, $locales_test_number, \@failures);
1150
1151     $locales_test_number++;
1152
1153     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
1154     report_multi_result($Locale, $locales_test_number, \@fold_failures);
1155
1156     undef @failures;
1157     undef @fold_failures;
1158
1159     foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
1160         my $ok;
1161         my $fold_ok;
1162         if ($is_utf8_locale) {
1163             use locale ':not_characters';
1164             $ok = $x =~ /[[:lower:]]/;
1165             $fold_ok = $x =~ /[[:upper:]]/i;
1166         }
1167         else {
1168             use locale;
1169             $ok = $x =~ /[[:lower:]]/;
1170             $fold_ok = $x =~ /[[:upper:]]/i;
1171         }
1172         push @failures, $x unless $ok;
1173         push @fold_failures, $x unless $fold_ok;
1174     }
1175
1176     $locales_test_number++;
1177     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
1178     report_multi_result($Locale, $locales_test_number, \@failures);
1179
1180     $locales_test_number++;
1181     $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
1182     report_multi_result($Locale, $locales_test_number, \@fold_failures);
1183
1184     {   # Find the alphabetic characters that are not considered alphabetics
1185         # in the default (C) locale.
1186
1187         no locale;
1188
1189         @Added_alpha = ();
1190         for (keys %UPPER, keys %lower, keys %BoThCaSe) {
1191             push(@Added_alpha, $_) if (/\W/);
1192         }
1193     }
1194
1195     @Added_alpha = sort { ord $a <=> ord $b } @Added_alpha;
1196
1197     debug "Added_alpha = ", disp_chars(@Added_alpha), "\n";
1198
1199     # Cross-check the whole 8-bit character set.
1200
1201     ++$locales_test_number;
1202     my @f;
1203     $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
1204     for (map { chr } 0..255) {
1205         if ($is_utf8_locale) {
1206             use locale ':not_characters';
1207             push @f, $_ unless /[[:word:]]/ == /\w/;
1208         }
1209         else {
1210             push @f, $_ unless /[[:word:]]/ == /\w/;
1211         }
1212     }
1213     report_multi_result($Locale, $locales_test_number, \@f);
1214
1215     ++$locales_test_number;
1216     undef @f;
1217     $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1218     for (map { chr } 0..255) {
1219         if ($is_utf8_locale) {
1220             use locale ':not_characters';
1221             push @f, $_ unless /[[:digit:]]/ == /\d/;
1222         }
1223         else {
1224             push @f, $_ unless /[[:digit:]]/ == /\d/;
1225         }
1226     }
1227     report_multi_result($Locale, $locales_test_number, \@f);
1228
1229     ++$locales_test_number;
1230     undef @f;
1231     $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1232     for (map { chr } 0..255) {
1233         if ($is_utf8_locale) {
1234             use locale ':not_characters';
1235             push @f, $_ unless /[[:space:]]/ == /\s/;
1236         }
1237         else {
1238             push @f, $_ unless /[[:space:]]/ == /\s/;
1239         }
1240     }
1241     report_multi_result($Locale, $locales_test_number, \@f);
1242
1243     ++$locales_test_number;
1244     undef @f;
1245     $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1246     for (map { chr } 0..255) {
1247         if ($is_utf8_locale) {
1248             use locale ':not_characters';
1249             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1250                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1251                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1252                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1253                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1254                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1255                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1256                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1257                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1258                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1259                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1260                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1261                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1262
1263                     # effectively is what [:cased:] would be if it existed.
1264                     (/[[:upper:][:lower:]]/i xor /[^[:upper:][:lower:]]/i);
1265         }
1266         else {
1267             push @f, $_ unless   (/[[:alpha:]]/ xor /[[:^alpha:]]/)   ||
1268                     (/[[:alnum:]]/ xor /[[:^alnum:]]/)   ||
1269                     (/[[:ascii:]]/ xor /[[:^ascii:]]/)   ||
1270                     (/[[:blank:]]/ xor /[[:^blank:]]/)   ||
1271                     (/[[:cntrl:]]/ xor /[[:^cntrl:]]/)   ||
1272                     (/[[:digit:]]/ xor /[[:^digit:]]/)   ||
1273                     (/[[:graph:]]/ xor /[[:^graph:]]/)   ||
1274                     (/[[:lower:]]/ xor /[[:^lower:]]/)   ||
1275                     (/[[:print:]]/ xor /[[:^print:]]/)   ||
1276                     (/[[:space:]]/ xor /[[:^space:]]/)   ||
1277                     (/[[:upper:]]/ xor /[[:^upper:]]/)   ||
1278                     (/[[:word:]]/  xor /[[:^word:]]/)    ||
1279                     (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1280                     (/[[:upper:][:lower:]]/i xor /[^[:upper:][:lower:]]/i);
1281         }
1282     }
1283     report_multi_result($Locale, $locales_test_number, \@f);
1284
1285     # The rules for the relationships are given in:
1286     # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1287
1288
1289     ++$locales_test_number;
1290     undef @f;
1291     $test_names{$locales_test_number} = 'Verify that [:lower:] contains at least a-z';
1292     for ('a' .. 'z') {
1293         if ($is_utf8_locale) {
1294             use locale ':not_characters';
1295             push @f, $_  unless /[[:lower:]]/;
1296         }
1297         else {
1298             push @f, $_  unless /[[:lower:]]/;
1299         }
1300     }
1301     report_multi_result($Locale, $locales_test_number, \@f);
1302
1303     ++$locales_test_number;
1304     undef @f;
1305     $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1306     for (map { chr } 0..255) {
1307         if ($is_utf8_locale) {
1308             use locale ':not_characters';
1309             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1310         }
1311         else {
1312             push @f, $_  if /[[:lower:]]/ and ! /[[:alpha:]]/;
1313         }
1314     }
1315     report_multi_result($Locale, $locales_test_number, \@f);
1316
1317     ++$locales_test_number;
1318     undef @f;
1319     $test_names{$locales_test_number} = 'Verify that [:upper:] contains at least A-Z';
1320     for ('A' .. 'Z') {
1321         if ($is_utf8_locale) {
1322             use locale ':not_characters';
1323             push @f, $_  unless /[[:upper:]]/;
1324         }
1325         else {
1326             push @f, $_  unless /[[:upper:]]/;
1327         }
1328     }
1329     report_multi_result($Locale, $locales_test_number, \@f);
1330
1331     ++$locales_test_number;
1332     undef @f;
1333     $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1334     for (map { chr } 0..255) {
1335         if ($is_utf8_locale) {
1336             use locale ':not_characters';
1337             push @f, $_  if /[[:upper:]]/ and ! /[[:alpha:]]/;
1338         }
1339         else {
1340             push @f, $_ if /[[:upper:]]/  and ! /[[:alpha:]]/;
1341         }
1342     }
1343     report_multi_result($Locale, $locales_test_number, \@f);
1344
1345     ++$locales_test_number;
1346     undef @f;
1347     $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1348     for (map { chr } 0..255) {
1349         if ($is_utf8_locale) {
1350             use locale ':not_characters';
1351             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1352         }
1353         else {
1354             push @f, $_ if /[[:lower:]]/i  and ! /[[:alpha:]]/;
1355         }
1356     }
1357     report_multi_result($Locale, $locales_test_number, \@f);
1358
1359     ++$locales_test_number;
1360     undef @f;
1361     $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1362     for (map { chr } 0..255) {
1363         if ($is_utf8_locale) {
1364             use locale ':not_characters';
1365             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1366         }
1367         else {
1368             push @f, $_ if /[[:alpha:]]/  and ! /[[:alnum:]]/;
1369         }
1370     }
1371     report_multi_result($Locale, $locales_test_number, \@f);
1372
1373     ++$locales_test_number;
1374     undef @f;
1375     $test_names{$locales_test_number} = 'Verify that [:digit:] contains at least 0-9';
1376     for ('0' .. '9') {
1377         if ($is_utf8_locale) {
1378             use locale ':not_characters';
1379             push @f, $_  unless /[[:digit:]]/;
1380         }
1381         else {
1382             push @f, $_  unless /[[:digit:]]/;
1383         }
1384     }
1385     report_multi_result($Locale, $locales_test_number, \@f);
1386
1387     ++$locales_test_number;
1388     undef @f;
1389     $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1390     for (map { chr } 0..255) {
1391         if ($is_utf8_locale) {
1392             use locale ':not_characters';
1393             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1394         }
1395         else {
1396             push @f, $_ if /[[:digit:]]/  and ! /[[:alnum:]]/;
1397         }
1398     }
1399     report_multi_result($Locale, $locales_test_number, \@f);
1400
1401     ++$locales_test_number;
1402     undef @f;
1403     $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1404     report_result($Locale, $locales_test_number, @{$posixes{'digit'}} == 10 || @{$posixes{'digit'}} == 20);
1405
1406     ++$locales_test_number;
1407     undef @f;
1408     $test_names{$locales_test_number} = 'Verify that if there is a second set of digits in [:digit:], they are consecutive';
1409     if (@{$posixes{'digit'}} == 20) {
1410         my $previous_ord;
1411         for (map { chr } 0..255) {
1412             next unless /[[:digit:]]/;
1413             next if /[0-9]/;
1414             if (defined $previous_ord) {
1415                 if ($is_utf8_locale) {
1416                     use locale ':not_characters';
1417                     push @f, $_ if ord $_ != $previous_ord + 1;
1418                 }
1419                 else {
1420                     push @f, $_ if ord $_ != $previous_ord + 1;
1421                 }
1422             }
1423             $previous_ord = ord $_;
1424         }
1425     }
1426     report_multi_result($Locale, $locales_test_number, \@f);
1427
1428     ++$locales_test_number;
1429     undef @f;
1430     my @xdigit_digits;  # :digit: & :xdigit:
1431     $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains one or two blocks of 10 consecutive [:digit:] chars';
1432     for (map { chr } 0..255) {
1433         if ($is_utf8_locale) {
1434             use locale ':not_characters';
1435             # For utf8 locales, we actually use a stricter test: that :digit:
1436             # is a subset of :xdigit:, as we know that only 0-9 should match
1437             push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
1438         }
1439         else {
1440             push @xdigit_digits, $_ if /[[:digit:]]/ and /[[:xdigit:]]/;
1441         }
1442     }
1443     if (! $is_utf8_locale) {
1444
1445         # For non-utf8 locales, @xdigit_digits is a list of the characters
1446         # that are both :xdigit: and :digit:.  Because :digit: is stored in
1447         # increasing code point order (unless the tests above failed),
1448         # @xdigit_digits is as well.  There should be exactly 10 or
1449         # 20 of these.
1450         if (@xdigit_digits != 10 && @xdigit_digits != 20) {
1451             @f = @xdigit_digits;
1452         }
1453         else {
1454
1455             # Look for contiguity in the series, adding any wrong ones to @f
1456             my @temp = @xdigit_digits;
1457             while (@temp > 1) {
1458                 push @f, $temp[1] if ($temp[0] != $temp[1] - 1)
1459
1460                                      # Skip this test for the 0th character of
1461                                      # the second block of 10, as it won't be
1462                                      # contiguous with the previous block
1463                                      && (! defined $xdigit_digits[10]
1464                                          || $temp[1] != $xdigit_digits[10]);
1465                 shift @temp;
1466             }
1467         }
1468     }
1469
1470     report_multi_result($Locale, $locales_test_number, \@f);
1471
1472     ++$locales_test_number;
1473     undef @f;
1474     $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains at least A-F, a-f';
1475     for ('A' .. 'F', 'a' .. 'f') {
1476         if ($is_utf8_locale) {
1477             use locale ':not_characters';
1478             push @f, $_  unless /[[:xdigit:]]/;
1479         }
1480         else {
1481             push @f, $_  unless /[[:xdigit:]]/;
1482         }
1483     }
1484     report_multi_result($Locale, $locales_test_number, \@f);
1485
1486     ++$locales_test_number;
1487     undef @f;
1488     $test_names{$locales_test_number} = 'Verify that any additional members of [:xdigit:], are in groups of 6 consecutive code points';
1489     my $previous_ord;
1490     my $count = 0;
1491     for my $chr (map { chr } 0..255) {
1492         next unless $chr =~ /[[:xdigit:]]/;
1493         if ($is_utf8_locale) {
1494             next if $chr =~ /[[:digit:]]/;
1495         }
1496         else {
1497             next if grep { $chr eq $_ } @xdigit_digits;
1498         }
1499         next if $chr =~ /[A-Fa-f]/;
1500         if (defined $previous_ord) {
1501             if ($is_utf8_locale) {
1502                 use locale ':not_characters';
1503                 push @f, $chr if ord $chr != $previous_ord + 1;
1504             }
1505             else {
1506                 push @f, $chr if ord $chr != $previous_ord + 1;
1507             }
1508         }
1509         $count++;
1510         if ($count == 6) {
1511             undef $previous_ord;
1512         }
1513         else {
1514             $previous_ord = ord $chr;
1515         }
1516     }
1517     report_multi_result($Locale, $locales_test_number, \@f);
1518
1519     ++$locales_test_number;
1520     undef @f;
1521     $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1522     for (map { chr } 0..255) {
1523         if ($is_utf8_locale) {
1524             use locale ':not_characters';
1525             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1526         }
1527         else {
1528             push @f, $_ if /[[:xdigit:]]/  and ! /[[:graph:]]/;
1529         }
1530     }
1531     report_multi_result($Locale, $locales_test_number, \@f);
1532
1533     # Note that xdigit doesn't have to be a subset of alnum
1534
1535     ++$locales_test_number;
1536     undef @f;
1537     $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1538     for (map { chr } 0..255) {
1539         if ($is_utf8_locale) {
1540             use locale ':not_characters';
1541             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1542         }
1543         else {
1544             push @f, $_ if /[[:punct:]]/  and ! /[[:graph:]]/;
1545         }
1546     }
1547     report_multi_result($Locale, $locales_test_number, \@f);
1548
1549     ++$locales_test_number;
1550     undef @f;
1551     $test_names{$locales_test_number} = 'Verify that the space character is not in [:graph:]';
1552     if ($is_utf8_locale) {
1553         use locale ':not_characters';
1554         push @f, " " if " " =~ /[[:graph:]]/;
1555     }
1556     else {
1557         push @f, " " if " " =~ /[[:graph:]]/;
1558     }
1559     report_multi_result($Locale, $locales_test_number, \@f);
1560
1561     ++$locales_test_number;
1562     undef @f;
1563     $test_names{$locales_test_number} = 'Verify that [:space:] contains at least [\f\n\r\t\cK ]';
1564     for (' ', "\f", "\n", "\r", "\t", "\cK") {
1565         if ($is_utf8_locale) {
1566             use locale ':not_characters';
1567             push @f, $_  unless /[[:space:]]/;
1568         }
1569         else {
1570             push @f, $_  unless /[[:space:]]/;
1571         }
1572     }
1573     report_multi_result($Locale, $locales_test_number, \@f);
1574
1575     ++$locales_test_number;
1576     undef @f;
1577     $test_names{$locales_test_number} = 'Verify that [:blank:] contains at least [\t ]';
1578     for (' ', "\t") {
1579         if ($is_utf8_locale) {
1580             use locale ':not_characters';
1581             push @f, $_  unless /[[:blank:]]/;
1582         }
1583         else {
1584             push @f, $_  unless /[[:blank:]]/;
1585         }
1586     }
1587     report_multi_result($Locale, $locales_test_number, \@f);
1588
1589     ++$locales_test_number;
1590     undef @f;
1591     $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1592     for (map { chr } 0..255) {
1593         if ($is_utf8_locale) {
1594             use locale ':not_characters';
1595             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1596         }
1597         else {
1598             push @f, $_ if /[[:blank:]]/  and ! /[[:space:]]/;
1599         }
1600     }
1601     report_multi_result($Locale, $locales_test_number, \@f);
1602
1603     ++$locales_test_number;
1604     undef @f;
1605     $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1606     for (map { chr } 0..255) {
1607         if ($is_utf8_locale) {
1608             use locale ':not_characters';
1609             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1610         }
1611         else {
1612             push @f, $_ if /[[:graph:]]/  and ! /[[:print:]]/;
1613         }
1614     }
1615     report_multi_result($Locale, $locales_test_number, \@f);
1616
1617     ++$locales_test_number;
1618     undef @f;
1619     $test_names{$locales_test_number} = 'Verify that the space character is in [:print:]';
1620     if ($is_utf8_locale) {
1621         use locale ':not_characters';
1622         push @f, " " if " " !~ /[[:print:]]/;
1623     }
1624     else {
1625         push @f, " " if " " !~ /[[:print:]]/;
1626     }
1627     report_multi_result($Locale, $locales_test_number, \@f);
1628
1629     ++$locales_test_number;
1630     undef @f;
1631     $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1632     for (map { chr } 0..255) {
1633         if ($is_utf8_locale) {
1634             use locale ':not_characters';
1635             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1636         }
1637         else {
1638             push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1639         }
1640     }
1641     report_multi_result($Locale, $locales_test_number, \@f);
1642
1643     ++$locales_test_number;
1644     undef @f;
1645     $test_names{$locales_test_number} = 'Verify that isn\'t both [:alpha:] and [:digit:]';
1646     for (map { chr } 0..255) {
1647         if ($is_utf8_locale) {
1648             use locale ':not_characters';
1649             push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1650         }
1651         else {
1652             push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1653         }
1654     }
1655     report_multi_result($Locale, $locales_test_number, \@f);
1656
1657     ++$locales_test_number;
1658     undef @f;
1659     $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1660     for (map { chr } 0..255) {
1661         if ($is_utf8_locale) {
1662             use locale ':not_characters';
1663             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1664         }
1665         else {
1666             push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1667         }
1668     }
1669     report_multi_result($Locale, $locales_test_number, \@f);
1670
1671     ++$locales_test_number;
1672     undef @f;
1673     $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1674     for (map { chr } 0..255) {
1675         if ($is_utf8_locale) {
1676             use locale ':not_characters';
1677             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1678         }
1679         else {
1680             push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1681         }
1682     }
1683     report_multi_result($Locale, $locales_test_number, \@f);
1684
1685     ++$locales_test_number;
1686     undef @f;
1687     $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1688     for (map { chr } 0..255) {
1689         if ($is_utf8_locale) {
1690             use locale ':not_characters';
1691             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1692         }
1693         else {
1694             push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1695         }
1696     }
1697     report_multi_result($Locale, $locales_test_number, \@f);
1698
1699     foreach ($first_casing_test_number..$locales_test_number) {
1700         $problematical_tests{$_} = 1;
1701     }
1702
1703
1704     # Test for read-only scalars' locale vs non-locale comparisons.
1705
1706     {
1707         no locale;
1708         my $ok;
1709         $a = "qwerty";
1710         if ($is_utf8_locale) {
1711             use locale ':not_characters';
1712             $ok = ($a cmp "qwerty") == 0;
1713         }
1714         else {
1715             use locale;
1716             $ok = ($a cmp "qwerty") == 0;
1717         }
1718         report_result($Locale, ++$locales_test_number, $ok);
1719         $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1720     }
1721
1722     {
1723         my ($from, $to, $lesser, $greater,
1724             @test, %test, $test, $yes, $no, $sign);
1725
1726         ++$locales_test_number;
1727         $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1728         $not_necessarily_a_problem_test_number = $locales_test_number;
1729         for (0..9) {
1730             # Select a slice.
1731             $from = int(($_*@{$posixes{'word'}})/10);
1732             $to = $from + int(@{$posixes{'word'}}/10);
1733             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1734             $lesser  = join('', @{$posixes{'word'}}[$from..$to]);
1735             # Select a slice one character on.
1736             $from++; $to++;
1737             $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1738             $greater = join('', @{$posixes{'word'}}[$from..$to]);
1739             if ($is_utf8_locale) {
1740                 use locale ':not_characters';
1741                 ($yes, $no, $sign) = ($lesser lt $greater
1742                                     ? ("    ", "not ", 1)
1743                                     : ("not ", "    ", -1));
1744             }
1745             else {
1746                 use locale;
1747                 ($yes, $no, $sign) = ($lesser lt $greater
1748                                     ? ("    ", "not ", 1)
1749                                     : ("not ", "    ", -1));
1750             }
1751             # all these tests should FAIL (return 0).  Exact lt or gt cannot
1752             # be tested because in some locales, say, eacute and E may test
1753             # equal.
1754             @test =
1755                 (
1756                     $no.'    ($lesser  le $greater)',  # 1
1757                     'not      ($lesser  ne $greater)', # 2
1758                     '         ($lesser  eq $greater)', # 3
1759                     $yes.'    ($lesser  ge $greater)', # 4
1760                     $yes.'    ($lesser  ge $greater)', # 5
1761                     $yes.'    ($greater le $lesser )', # 7
1762                     'not      ($greater ne $lesser )', # 8
1763                     '         ($greater eq $lesser )', # 9
1764                     $no.'     ($greater ge $lesser )', # 10
1765                     'not (($lesser cmp $greater) == -($sign))' # 11
1766                     );
1767             @test{@test} = 0 x @test;
1768             $test = 0;
1769             for my $ti (@test) {
1770                 if ($is_utf8_locale) {
1771                     use locale ':not_characters';
1772                     $test{$ti} = eval $ti;
1773                 }
1774                 else {
1775                     # Already in 'use locale';
1776                     $test{$ti} = eval $ti;
1777                 }
1778                 $test ||= $test{$ti}
1779             }
1780             report_result($Locale, $locales_test_number, $test == 0);
1781             if ($test) {
1782                 debug "lesser  = '$lesser'\n";
1783                 debug "greater = '$greater'\n";
1784                 debug "lesser cmp greater = ",
1785                         $lesser cmp $greater, "\n";
1786                 debug "greater cmp lesser = ",
1787                         $greater cmp $lesser, "\n";
1788                 debug "(greater) from = $from, to = $to\n";
1789                 for my $ti (@test) {
1790                     debugf("# %-40s %-4s", $ti,
1791                             $test{$ti} ? 'FAIL' : 'ok');
1792                     if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1793                         debugf("(%s == %4d)", $1, eval $1);
1794                     }
1795                     debugf("\n#");
1796                 }
1797
1798                 last;
1799             }
1800         }
1801
1802         use locale;
1803
1804         my @sorted_controls;
1805
1806         ++$locales_test_number;
1807         $test_names{$locales_test_number}
1808                 = 'Skip in locales where there are no controls;'
1809                 . ' otherwise verify that \0 sorts before any (other) control';
1810         if (! $posixes{'cntrl'}) {
1811             report_result($Locale, $locales_test_number, 1);
1812
1813             # We use all code points for the tests below since there aren't
1814             # any controls
1815             push @sorted_controls, chr $_ for 1..255;
1816             @sorted_controls = sort @sorted_controls;
1817         }
1818         else {
1819             @sorted_controls = @{$posixes{'cntrl'}};
1820             push @sorted_controls, "\0",
1821                                 unless grep { $_ eq "\0" } @sorted_controls;
1822             @sorted_controls = sort @sorted_controls;
1823             my $output = "";
1824             for my $control (@sorted_controls) {
1825                 $output .= " " . disp_chars($control);
1826             }
1827             debug "sorted :cntrl: (plus NUL) = $output\n";
1828             my $ok = $sorted_controls[0] eq "\0";
1829             report_result($Locale, $locales_test_number, $ok);
1830
1831             shift @sorted_controls if $ok;
1832         }
1833
1834         my $lowest_control = $sorted_controls[0];
1835
1836         ++$locales_test_number;
1837         $test_names{$locales_test_number}
1838             = 'Skip in locales where all controls have primary sorting weight; '
1839             . 'otherwise verify that \0 doesn\'t have primary sorting weight';
1840         if ("a${lowest_control}c" lt "ab") {
1841             report_result($Locale, $locales_test_number, 1);
1842         }
1843         else {
1844             my $ok = "ab" lt "a\0c";
1845             report_result($Locale, $locales_test_number, $ok);
1846         }
1847
1848         ++$locales_test_number;
1849         $test_names{$locales_test_number}
1850                             = 'Verify that strings with embedded NUL collate';
1851         my $ok = "a\0a\0a" lt "a${lowest_control}a${lowest_control}a";
1852         report_result($Locale, $locales_test_number, $ok);
1853
1854         ++$locales_test_number;
1855         $test_names{$locales_test_number}
1856                             = 'Verify that strings with embedded NUL and '
1857                             . 'extra trailing NUL collate';
1858         $ok = "a\0a\0" lt "a${lowest_control}a${lowest_control}";
1859         report_result($Locale, $locales_test_number, $ok);
1860
1861         ++$locales_test_number;
1862         $test_names{$locales_test_number}
1863                             = 'Verify that empty strings collate';
1864         $ok = "" le "";
1865         report_result($Locale, $locales_test_number, $ok);
1866
1867         ++$locales_test_number;
1868         $test_names{$locales_test_number}
1869             = "Skip in non-UTF-8 locales; otherwise verify that UTF8ness "
1870             . "doesn't matter with collation";
1871         if (! $is_utf8_locale) {
1872             report_result($Locale, $locales_test_number, 1);
1873         }
1874         else {
1875
1876             # khw can't think of anything better.  Start with a string that is
1877             # higher than its UTF-8 representation in both EBCDIC and ASCII
1878             my $string = chr utf8::unicode_to_native(0xff);
1879             my $utf8_string = $string;
1880             utf8::upgrade($utf8_string);
1881
1882             # 8 should be lt 9 in all locales (except ones that aren't
1883             # ASCII-based, which might fail this)
1884             $ok = ("a${string}8") lt ("a${utf8_string}9");
1885             report_result($Locale, $locales_test_number, $ok);
1886         }
1887
1888         ++$locales_test_number;
1889         $test_names{$locales_test_number}
1890             = "Skip in UTF-8 locales; otherwise verify that single byte "
1891             . "collates before 0x100 and above";
1892         if ($is_utf8_locale) {
1893             report_result($Locale, $locales_test_number, 1);
1894         }
1895         else {
1896             my $max_collating = chr 0;  # Find byte that collates highest
1897             for my $i (0 .. 255) {
1898                 my $char = chr $i;
1899                 $max_collating = $char if $char gt $max_collating;
1900             }
1901             $ok = $max_collating lt chr 0x100;
1902             report_result($Locale, $locales_test_number, $ok);
1903         }
1904
1905         ++$locales_test_number;
1906         $test_names{$locales_test_number}
1907             = "Skip in UTF-8 locales; otherwise verify that 0x100 and "
1908             . "above collate in code point order";
1909         if ($is_utf8_locale) {
1910             report_result($Locale, $locales_test_number, 1);
1911         }
1912         else {
1913             $ok = chr 0x100 lt chr 0x101;
1914             report_result($Locale, $locales_test_number, $ok);
1915         }
1916     }
1917
1918     my $ok1;
1919     my $ok2;
1920     my $ok3;
1921     my $ok4;
1922     my $ok5;
1923     my $ok6;
1924     my $ok7;
1925     my $ok8;
1926     my $ok9;
1927     my $ok10;
1928     my $ok11;
1929     my $ok12;
1930     my $ok13;
1931     my $ok14;
1932     my $ok14_5;
1933     my $ok15;
1934     my $ok16;
1935     my $ok17;
1936     my $ok18;
1937     my $ok19;
1938     my $ok20;
1939     my $ok21;
1940
1941     my $c;
1942     my $d;
1943     my $e;
1944     my $f;
1945     my $g;
1946     my $h;
1947     my $i;
1948     my $j;
1949
1950     if (! $is_utf8_locale) {
1951         use locale;
1952
1953         my ($x, $y) = (1.23, 1.23);
1954
1955         $a = "$x";
1956         printf ''; # printf used to reset locale to "C"
1957         $b = "$y";
1958         $ok1 = $a eq $b;
1959
1960         $c = "$x";
1961         my $z = sprintf ''; # sprintf used to reset locale to "C"
1962         $d = "$y";
1963         $ok2 = $c eq $d;
1964         {
1965
1966             use warnings;
1967             my $w = 0;
1968             local $SIG{__WARN__} =
1969                 sub {
1970                     print "# @_\n";
1971                     $w++;
1972                 };
1973
1974             # The == (among other ops) used to warn for locales
1975             # that had something else than "." as the radix character.
1976
1977             $ok3 = $c == 1.23;
1978             $ok4 = $c == $x;
1979             $ok5 = $c == $d;
1980             {
1981                 no locale;
1982
1983                 $e = "$x";
1984
1985                 $ok6 = $e == 1.23;
1986                 $ok7 = $e == $x;
1987                 $ok8 = $e == $c;
1988             }
1989
1990             $f = "1.23";
1991             $g = 2.34;
1992             $h = 1.5;
1993             $i = 1.25;
1994             $j = "$h:$i";
1995
1996             $ok9 = $f == 1.23;
1997             $ok10 = $f == $x;
1998             $ok11 = $f == $c;
1999             $ok12 = abs(($f + $g) - 3.57) < 0.01;
2000             $ok13 = $w == 0;
2001             $ok14 = $ok14_5 = $ok15 = $ok16 = 1;  # Skip for non-utf8 locales
2002         }
2003         {
2004             no locale;
2005             $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
2006         }
2007         $ok18 = $j eq sprintf("%g:%g", $h, $i);
2008     }
2009     else {
2010         use locale ':not_characters';
2011
2012         my ($x, $y) = (1.23, 1.23);
2013         $a = "$x";
2014         printf ''; # printf used to reset locale to "C"
2015         $b = "$y";
2016         $ok1 = $a eq $b;
2017
2018         $c = "$x";
2019         my $z = sprintf ''; # sprintf used to reset locale to "C"
2020         $d = "$y";
2021         $ok2 = $c eq $d;
2022         {
2023             use warnings;
2024             my $w = 0;
2025             local $SIG{__WARN__} =
2026                 sub {
2027                     print "# @_\n";
2028                     $w++;
2029                 };
2030             $ok3 = $c == 1.23;
2031             $ok4 = $c == $x;
2032             $ok5 = $c == $d;
2033             {
2034                 no locale;
2035                 $e = "$x";
2036
2037                 $ok6 = $e == 1.23;
2038                 $ok7 = $e == $x;
2039                 $ok8 = $e == $c;
2040             }
2041
2042             $f = "1.23";
2043             $g = 2.34;
2044             $h = 1.5;
2045             $i = 1.25;
2046             $j = "$h:$i";
2047
2048             $ok9 = $f == 1.23;
2049             $ok10 = $f == $x;
2050             $ok11 = $f == $c;
2051             $ok12 = abs(($f + $g) - 3.57) < 0.01;
2052             $ok13 = $w == 0;
2053
2054             # Look for non-ASCII error messages, and verify that the first
2055             # such is in UTF-8 (the others almost certainly will be like the
2056             # first).  This is only done if the current locale has LC_MESSAGES
2057             $ok14 = 1;
2058             $ok14_5 = 1;
2059             if (   locales_enabled('LC_MESSAGES')
2060                 && setlocale(&POSIX::LC_MESSAGES, $Locale))
2061             {
2062                 foreach my $err (keys %!) {
2063                     use Errno;
2064                     $! = eval "&Errno::$err";   # Convert to strerror() output
2065                     my $errnum = 0+$!;
2066                     my $strerror = "$!";
2067                     if ("$strerror" =~ /\P{ASCII}/) {
2068                         $ok14 = utf8::is_utf8($strerror);
2069                         no locale;
2070                         $ok14_5 = "$!" !~ /\P{ASCII}/;
2071                         debug( disp_str(
2072                         "non-ASCII \$! for error $errnum='$strerror'"))
2073                                                                    if ! $ok14_5;
2074                         last;
2075                     }
2076                 }
2077             }
2078
2079             # Similarly, we verify that a non-ASCII radix is in UTF-8.  This
2080             # also catches if there is a disparity between sprintf and
2081             # stringification.
2082
2083             my $string_g = "$g";
2084             my $sprintf_g = sprintf("%g", $g);
2085
2086             $ok15 = $string_g =~ / ^ \p{ASCII}+ $ /x || utf8::is_utf8($string_g);
2087             $ok16 = $sprintf_g eq $string_g;
2088         }
2089         {
2090             no locale;
2091             $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
2092         }
2093         $ok18 = $j eq sprintf("%g:%g", $h, $i);
2094     }
2095
2096     $ok19 = $ok20 = 1;
2097     if (setlocale(&POSIX::LC_TIME, $Locale)) { # These tests aren't affected by
2098                                                # :not_characters
2099         my @times = CORE::localtime();
2100
2101         use locale;
2102         $ok19 = POSIX::strftime("%p", @times) ne "%p"; # [perl #119425]
2103         my $date = POSIX::strftime("'%A'  '%B'  '%Z'  '%p'", @times);
2104         debug("'Day' 'Month' 'TZ' 'am/pm' = ", disp_str($date));
2105
2106         # If there is any non-ascii, it better be UTF-8 in a UTF-8 locale, and
2107         # not UTF-8 if the locale isn't UTF-8.
2108         $ok20 = $date =~ / ^ \p{ASCII}+ $ /x
2109                 || $is_utf8_locale == utf8::is_utf8($date);
2110     }
2111
2112     $ok21 = 1;
2113     if (locales_enabled('LC_MESSAGES')) {
2114         foreach my $err (keys %!) {
2115             no locale;
2116             use Errno;
2117             $! = eval "&Errno::$err";   # Convert to strerror() output
2118             my $strerror = "$!";
2119             if ($strerror =~ /\P{ASCII}/) {
2120                 $ok21 = 0;
2121                 debug(disp_str("non-ASCII strerror=$strerror"));
2122                 last;
2123             }
2124         }
2125     }
2126
2127     report_result($Locale, ++$locales_test_number, $ok1);
2128     $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
2129     my $first_a_test = $locales_test_number;
2130
2131     debug "$first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
2132
2133     report_result($Locale, ++$locales_test_number, $ok2);
2134     $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
2135
2136     my $first_c_test = $locales_test_number;
2137
2138     $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
2139     if ($Config{usequadmath}) {
2140         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2141         report_result($Locale, $locales_test_number, 1);
2142     } else {
2143         report_result($Locale, $locales_test_number, $ok3);
2144         $problematical_tests{$locales_test_number} = 1;
2145     }
2146
2147     $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
2148     if ($Config{usequadmath}) {
2149         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2150         report_result($Locale, $locales_test_number, 1);
2151     } else {
2152         report_result($Locale, $locales_test_number, $ok4);
2153         $problematical_tests{$locales_test_number} = 1;
2154     }
2155
2156     report_result($Locale, ++$locales_test_number, $ok5);
2157     $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
2158     $problematical_tests{$locales_test_number} = 1;
2159
2160     debug "$first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
2161
2162     report_result($Locale, ++$locales_test_number, $ok6);
2163     $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
2164     my $first_e_test = $locales_test_number;
2165
2166     report_result($Locale, ++$locales_test_number, $ok7);
2167     $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
2168
2169     $test_names{++$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
2170     if ($Config{usequadmath}) {
2171         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2172         report_result($Locale, $locales_test_number, 1);
2173     } else {
2174         report_result($Locale, $locales_test_number, $ok8);
2175         $problematical_tests{$locales_test_number} = 1;
2176     }
2177
2178     debug "$first_e_test..$locales_test_number: \$e = $e, no locale\n";
2179
2180     report_result($Locale, ++$locales_test_number, $ok9);
2181     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
2182     $problematical_tests{$locales_test_number} = 1;
2183     my $first_f_test = $locales_test_number;
2184
2185     report_result($Locale, ++$locales_test_number, $ok10);
2186     $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
2187     $problematical_tests{$locales_test_number} = 1;
2188
2189     $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';
2190     if ($Config{usequadmath}) {
2191         print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2192         report_result($Locale, $locales_test_number, 1);
2193     } else {
2194         report_result($Locale, $locales_test_number, $ok11);
2195         $problematical_tests{$locales_test_number} = 1;
2196     }
2197
2198     report_result($Locale, ++$locales_test_number, $ok12);
2199     $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';
2200     $problematical_tests{$locales_test_number} = 1;
2201
2202     report_result($Locale, ++$locales_test_number, $ok13);
2203     $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
2204     $problematical_tests{$locales_test_number} = 1;
2205
2206     report_result($Locale, ++$locales_test_number, $ok14);
2207     $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
2208
2209     report_result($Locale, ++$locales_test_number, $ok14_5);
2210     $test_names{$locales_test_number} = '... and are ASCII outside "use locale"';
2211
2212     report_result($Locale, ++$locales_test_number, $ok15);
2213     $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
2214
2215     report_result($Locale, ++$locales_test_number, $ok16);
2216     $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
2217     $problematical_tests{$locales_test_number} = 1;
2218
2219     report_result($Locale, ++$locales_test_number, $ok17);
2220     $test_names{$locales_test_number} = 'Verify that a sprintf of a number outside locale scope uses a dot radix';
2221
2222     report_result($Locale, ++$locales_test_number, $ok18);
2223     $test_names{$locales_test_number} = 'Verify that a sprintf of a number back within locale scope uses locale radix';
2224     $problematical_tests{$locales_test_number} = 1;
2225
2226     report_result($Locale, ++$locales_test_number, $ok19);
2227     $test_names{$locales_test_number} = 'Verify that strftime doesn\'t return "%p" in locales where %p is empty';
2228
2229     report_result($Locale, ++$locales_test_number, $ok20);
2230     $test_names{$locales_test_number} = 'Verify that strftime returns date with UTF-8 flag appropriately set';
2231     $problematical_tests{$locales_test_number} = 1;   # This is broken in
2232                                                       # OS X 10.9.3
2233
2234     report_result($Locale, ++$locales_test_number, $ok21);
2235     $test_names{$locales_test_number} = '"$!" is ASCII only outside of locale scope';
2236
2237     debug "$first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
2238
2239     # Does taking lc separately differ from taking
2240     # the lc "in-line"?  (This was the bug 19990704.002 (#965), change #3568.)
2241     # The bug was in the caching of the 'o'-magic.
2242     if (! $is_utf8_locale) {
2243         use locale;
2244
2245         sub lcA {
2246             my $lc0 = lc $_[0];
2247             my $lc1 = lc $_[1];
2248             return $lc0 cmp $lc1;
2249         }
2250
2251         sub lcB {
2252             return lc($_[0]) cmp lc($_[1]);
2253         }
2254
2255         my $x = "ab";
2256         my $y = "aa";
2257         my $z = "AB";
2258
2259         report_result($Locale, ++$locales_test_number,
2260                     lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
2261                     lcA($x, $z) == 0 && lcB($x, $z) == 0);
2262     }
2263     else {
2264         use locale ':not_characters';
2265
2266         sub lcC {
2267             my $lc0 = lc $_[0];
2268             my $lc1 = lc $_[1];
2269             return $lc0 cmp $lc1;
2270         }
2271
2272         sub lcD {
2273             return lc($_[0]) cmp lc($_[1]);
2274         }
2275
2276         my $x = "ab";
2277         my $y = "aa";
2278         my $z = "AB";
2279
2280         report_result($Locale, ++$locales_test_number,
2281                     lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
2282                     lcC($x, $z) == 0 && lcD($x, $z) == 0);
2283     }
2284     $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
2285
2286     # Does lc of an UPPER (if different from the UPPER) match
2287     # case-insensitively the UPPER, and does the UPPER match
2288     # case-insensitively the lc of the UPPER.  And vice versa.
2289     {
2290         use locale;
2291         no utf8;
2292         my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
2293
2294         my @f = ();
2295         ++$locales_test_number;
2296         $test_names{$locales_test_number} = 'Verify case insensitive matching works';
2297         foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
2298             if (! $is_utf8_locale) {
2299                 my $y = lc $x;
2300                 next unless uc $y eq $x;
2301                 debug_more( "UPPER=", disp_chars(($x)),
2302                             "; lc=", disp_chars(($y)), "; ",
2303                             "; fc=", disp_chars((fc $x)), "; ",
2304                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2305                             $x =~ /\Q$y/i ? 1 : 0,
2306                             "; ",
2307                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2308                             $y =~ /\Q$x/i ? 1 : 0,
2309                             "\n");
2310                 #
2311                 # If $x and $y contain regular expression characters
2312                 # AND THEY lowercase (/i) to regular expression characters,
2313                 # regcomp() will be mightily confused.  No, the \Q doesn't
2314                 # help here (maybe regex engine internal lowercasing
2315                 # is done after the \Q?)  An example of this happening is
2316                 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
2317                 # the chr(173) (the "[") is the lowercase of the chr(235).
2318                 #
2319                 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
2320                 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
2321                 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
2322                 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
2323                 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
2324                 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
2325                 #
2326                 # Similar things can happen even under (bastardised)
2327                 # non-EBCDIC locales: in many European countries before the
2328                 # advent of ISO 8859-x nationally customised versions of
2329                 # ISO 646 were devised, reusing certain punctuation
2330                 # characters for modified characters needed by the
2331                 # country/language.  For example, the "|" might have
2332                 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
2333                 #
2334                 if ($x =~ $re || $y =~ $re) {
2335                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2336                     next;
2337                 }
2338                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2339
2340                 # fc is not a locale concept, so Perl uses lc for it.
2341                 push @f, $x unless lc $x eq fc $x;
2342             }
2343             else {
2344                 use locale ':not_characters';
2345                 my $y = lc $x;
2346                 next unless uc $y eq $x;
2347                 debug_more( "UPPER=", disp_chars(($x)),
2348                             "; lc=", disp_chars(($y)), "; ",
2349                             "; fc=", disp_chars((fc $x)), "; ",
2350                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2351                             $x =~ /\Q$y/i ? 1 : 0,
2352                             "; ",
2353                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2354                             $y =~ /\Q$x/i ? 1 : 0,
2355                             "\n");
2356
2357                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2358
2359                 # The places where Unicode's lc is different from fc are
2360                 # skipped here by virtue of the 'next unless uc...' line above
2361                 push @f, $x unless lc $x eq fc $x;
2362             }
2363         }
2364
2365         foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
2366             if (! $is_utf8_locale) {
2367                 my $y = uc $x;
2368                 next unless lc $y eq $x;
2369                 debug_more( "lower=", disp_chars(($x)),
2370                             "; uc=", disp_chars(($y)), "; ",
2371                             "; fc=", disp_chars((fc $x)), "; ",
2372                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2373                             $x =~ /\Q$y/i ? 1 : 0,
2374                             "; ",
2375                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2376                             $y =~ /\Q$x/i ? 1 : 0,
2377                             "\n");
2378                 if ($x =~ $re || $y =~ $re) { # See above.
2379                     print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2380                     next;
2381                 }
2382                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2383
2384                 push @f, $x unless lc $x eq fc $x;
2385             }
2386             else {
2387                 use locale ':not_characters';
2388                 my $y = uc $x;
2389                 next unless lc $y eq $x;
2390                 debug_more( "lower=", disp_chars(($x)),
2391                             "; uc=", disp_chars(($y)), "; ",
2392                             "; fc=", disp_chars((fc $x)), "; ",
2393                             disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2394                             $x =~ /\Q$y/i ? 1 : 0,
2395                             "; ",
2396                             disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2397                             $y =~ /\Q$x/i ? 1 : 0,
2398                             "\n");
2399                 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2400
2401                 push @f, $x unless lc $x eq fc $x;
2402             }
2403         }
2404         report_multi_result($Locale, $locales_test_number, \@f);
2405         $problematical_tests{$locales_test_number} = 1;
2406     }
2407
2408     # [perl #109318]
2409     {
2410         my @f = ();
2411         ++$locales_test_number;
2412         $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
2413         $problematical_tests{$locales_test_number} = 1;
2414
2415         my $radix = POSIX::localeconv()->{decimal_point};
2416         my @nums = (
2417              "3.14e+9",  "3${radix}14e+9",  "3.14e-9",  "3${radix}14e-9",
2418             "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
2419         );
2420
2421         if (! $is_utf8_locale) {
2422             use locale;
2423             for my $num (@nums) {
2424                 push @f, $num
2425                     unless sprintf("%g", $num) =~ /3.+14/;
2426             }
2427         }
2428         else {
2429             use locale ':not_characters';
2430             for my $num (@nums) {
2431                 push @f, $num
2432                     unless sprintf("%g", $num) =~ /3.+14/;
2433             }
2434         }
2435
2436         if ($Config{usequadmath}) {
2437             print "# Skip: no locale radix with usequadmath ($Locale)\n";
2438             report_result($Locale, $locales_test_number, 1);
2439         } else {
2440             report_result($Locale, $locales_test_number, @f == 0);
2441             if (@f) {
2442                 print "# failed $locales_test_number locale '$Locale' numbers @f\n"
2443             }
2444         }
2445     }
2446 }
2447
2448 my $final_locales_test_number = $locales_test_number;
2449
2450 # Recount the errors.
2451
2452 TEST_NUM:
2453 foreach $test_num ($first_locales_test_number..$final_locales_test_number) {
2454     if (%setlocale_failed) {
2455         print "not ";
2456     }
2457     elsif ($Problem{$test_num}
2458            || ! defined $Okay{$test_num}
2459            || ! @{$Okay{$test_num}})
2460     {
2461         if (defined $not_necessarily_a_problem_test_number
2462             && $test_num == $not_necessarily_a_problem_test_number)
2463         {
2464             print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
2465             print "# It usually indicates a problem in the environment,\n";
2466             print "# not in Perl itself.\n";
2467         }
2468
2469         # If there are any locales that pass this test, or are known-bad, it
2470         # may be that there are enough passes that we TODO the failure.
2471         if (($Okay{$test_num} || $Known_bad_locale{$test_num})
2472             && grep { $_ == $test_num } keys %problematical_tests)
2473         {
2474             no warnings 'experimental::postderef';
2475
2476             # Don't count the known-bad failures when calculating the
2477             # percentage that fail.
2478             my $known_failures = (exists $Known_bad_locale{$test_num})
2479                                   ? scalar(keys $Known_bad_locale{$test_num}->%*)
2480                                   : 0;
2481             my $adjusted_failures = scalar(keys $Problem{$test_num}->%*)
2482                                     - $known_failures;
2483
2484             # Specially handle failures where only known-bad locales fail.
2485             # This makes the diagnositics clearer.
2486             if ($adjusted_failures <= 0) {
2487                 print "not ok $test_num $test_names{$test_num} # TODO fails only on ",
2488                                                                 "known bad locales: ",
2489                       join " ", keys $Known_bad_locale{$test_num}->%*, "\n";
2490                 next TEST_NUM;
2491             }
2492
2493             # Round to nearest .1%
2494             my $percent_fail = (int(.5 + (1000 * $adjusted_failures
2495                                           / scalar(@Locale))))
2496                                / 10;
2497             if ($percent_fail < $acceptable_failure_percentage) {
2498                 if (! $debug) {
2499                     $test_names{$test_num} .= 'TODO';
2500                     print "# ", 100 - $percent_fail, "% of locales not known to be problematic on this platform\n";
2501                     print "# pass the following test, so it is likely that the failures\n";
2502                     print "# are errors in the locale definitions.  The test is marked TODO, as the\n";
2503                     print "# problem is not likely to be Perl's\n";
2504                 }
2505             }
2506             if ($debug) {
2507                 print "# $percent_fail% of locales (",
2508                       scalar(keys $Problem{$test_num}->%*),
2509                       " of ",
2510                       scalar(@Locale),
2511                       ") fail the above test (TODO cut-off is ",
2512                       $acceptable_failure_percentage,
2513                       "%)\n";
2514             }
2515         }
2516         print "#\n";
2517         if ($debug) {
2518             print "# The code points that had this failure are given above.  Look for lines\n";
2519             print "# that match 'failed $test_num'\n";
2520         }
2521         else {
2522             print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2523             print "# Then look at that output for lines that match 'failed $test_num'\n";
2524         }
2525         print "not ";
2526     }
2527     print "ok $test_num";
2528     if (defined $test_names{$test_num}) {
2529         # If TODO is in the test name, make it thus
2530         my $todo = $test_names{$test_num} =~ s/TODO\s*//;
2531         print " $test_names{$test_num}";
2532         print " # TODO" if $todo;
2533     }
2534     print "\n";
2535 }
2536
2537 $test_num = $final_locales_test_number;
2538
2539 unless ( $^O =~ m!^(dragonfly|openbsd|bitrig|mirbsd)$! ) {
2540     # perl #115808
2541     use warnings;
2542     my $warned = 0;
2543     local $SIG{__WARN__} = sub {
2544         $warned = $_[0] =~ /uninitialized/;
2545     };
2546     my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
2547     ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
2548 }
2549
2550 # Test that tainting and case changing works on utf8 strings.  These tests are
2551 # placed last to avoid disturbing the hard-coded test numbers that existed at
2552 # the time these were added above this in this file.
2553 # This also tests that locale overrides unicode_strings in the same scope for
2554 # non-utf8 strings.
2555 setlocale(&POSIX::LC_ALL, "C");
2556 {
2557     use locale;
2558     use feature 'unicode_strings';
2559
2560     foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
2561         my @list;   # List of code points to test for $function
2562
2563         # Used to calculate the changed case for ASCII characters by using the
2564         # ord, instead of using one of the functions under test.
2565         my $ascii_case_change_delta;
2566         my $above_latin1_case_change_delta; # Same for the specific ords > 255
2567                                             # that we use
2568
2569         # We test an ASCII character, which should change case;
2570         # a Latin1 character, which shouldn't change case under this C locale,
2571         # an above-Latin1 character that when the case is changed would cross
2572         #   the 255/256 boundary, so doesn't change case
2573         #   (the \x{149} is one of these, but changes into 2 characters, the
2574         #   first one of which doesn't cross the boundary.
2575         # the final one in each list is an above-Latin1 character whose case
2576         #   does change.  The code below uses its position in its list as a
2577         #   marker to indicate that it, unlike the other code points above
2578         #   ASCII, has a successful case change
2579         #
2580         # All casing operations under locale (but not :not_characters) should
2581         # taint
2582         if ($function =~ /^u/) {
2583             @list = ("", "a",
2584                      chr(utf8::unicode_to_native(0xe0)),
2585                      chr(utf8::unicode_to_native(0xff)),
2586                      "\x{fb00}", "\x{149}", "\x{101}");
2587             $ascii_case_change_delta = ($is_ebcdic) ? +64 : -32;
2588             $above_latin1_case_change_delta = -1;
2589         }
2590         else {
2591             @list = ("", "A",
2592                      chr(utf8::unicode_to_native(0xC0)),
2593                      "\x{17F}", "\x{100}");
2594             $ascii_case_change_delta = ($is_ebcdic) ? -64 : +32;
2595             $above_latin1_case_change_delta = +1;
2596         }
2597         foreach my $is_utf8_locale (0 .. 1) {
2598             foreach my $j (0 .. $#list) {
2599                 my $char = $list[$j];
2600
2601                 for my $encoded_in_utf8 (0 .. 1) {
2602                     my $should_be;
2603                     my $changed;
2604                     if (! $is_utf8_locale) {
2605                         no warnings 'locale';
2606                         $should_be = ($j == $#list)
2607                             ? chr(ord($char) + $above_latin1_case_change_delta)
2608                             : (length $char == 0 || utf8::native_to_unicode(ord($char)) > 127)
2609                               ? $char
2610                               : chr(ord($char) + $ascii_case_change_delta);
2611
2612                         # This monstrosity is in order to avoid using an eval,
2613                         # which might perturb the results
2614                         $changed = ($function eq "uc")
2615                                     ? uc($char)
2616                                     : ($function eq "ucfirst")
2617                                       ? ucfirst($char)
2618                                       : ($function eq "lc")
2619                                         ? lc($char)
2620                                         : ($function eq "lcfirst")
2621                                           ? lcfirst($char)
2622                                           : ($function eq "fc")
2623                                             ? fc($char)
2624                                             : die("Unexpected function \"$function\"");
2625                     }
2626                     else {
2627                         {
2628                             no locale;
2629
2630                             # For utf8-locales the case changing functions
2631                             # should work just like they do outside of locale.
2632                             # Can use eval here because not testing it when
2633                             # not in locale.
2634                             $should_be = eval "$function('$char')";
2635                             die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if  $@;
2636
2637                         }
2638                         use locale ':not_characters';
2639                         $changed = ($function eq "uc")
2640                                     ? uc($char)
2641                                     : ($function eq "ucfirst")
2642                                       ? ucfirst($char)
2643                                       : ($function eq "lc")
2644                                         ? lc($char)
2645                                         : ($function eq "lcfirst")
2646                                           ? lcfirst($char)
2647                                           : ($function eq "fc")
2648                                             ? fc($char)
2649                                             : die("Unexpected function \"$function\"");
2650                     }
2651                     ok($changed eq $should_be,
2652                         "$function(\"$char\") in C locale "
2653                         . (($is_utf8_locale)
2654                             ? "(use locale ':not_characters'"
2655                             : "(use locale")
2656                         . (($encoded_in_utf8)
2657                             ? "; encoded in utf8)"
2658                             : "; not encoded in utf8)")
2659                         . " should be \"$should_be\", got \"$changed\"");
2660
2661                     # Tainting shouldn't happen for use locale :not_character
2662                     # (a utf8 locale)
2663                     (! $is_utf8_locale)
2664                     ? check_taint($changed)
2665                     : check_taint_not($changed);
2666
2667                     # Use UTF-8 next time through the loop
2668                     utf8::upgrade($char);
2669                 }
2670             }
2671         }
2672     }
2673 }
2674
2675 # Give final advice.
2676
2677 my $didwarn = 0;
2678
2679 foreach ($first_locales_test_number..$final_locales_test_number) {
2680     if ($Problem{$_}) {
2681         my @f = sort keys %{ $Problem{$_} };
2682
2683         # Don't list the failures caused by known-bad locales.
2684         if (exists $known_bad_locales{$^O}) {
2685             @f = grep { $_ !~ $known_bad_locales{$^O} } @f;
2686             next unless @f;
2687         }
2688         my $f = join(" ", @f);
2689         $f =~ s/(.{50,60}) /$1\n#\t/g;
2690         print
2691             "#\n",
2692             "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
2693             "#\t", $f, "\n#\n",
2694             "# on your system may have errors because the locale test $_\n",
2695             "# \"$test_names{$_}\"\n",
2696             "# failed in ", (@f == 1 ? "that locale" : "those locales"),
2697             ".\n";
2698         print <<EOW;
2699 #
2700 # If your users are not using these locales you are safe for the moment,
2701 # but please report this failure first to perlbug\@perl.org using the
2702 # perlbug script (as described in the INSTALL file) so that the exact
2703 # details of the failures can be sorted out first and then your operating
2704 # system supplier can be alerted about these anomalies.
2705 #
2706 EOW
2707         $didwarn = 1;
2708     }
2709 }
2710
2711 # Tell which locales were okay and which were not.
2712
2713 if ($didwarn) {
2714     my (@s, @F);
2715
2716     foreach my $l (@Locale) {
2717         my $p = 0;
2718         if ($setlocale_failed{$l}) {
2719             $p++;
2720         }
2721         else {
2722             foreach my $t
2723                         ($first_locales_test_number..$final_locales_test_number)
2724             {
2725                 $p++ if $Problem{$t}{$l};
2726             }
2727         }
2728         push @s, $l if $p == 0;
2729         push @F, $l unless $p == 0;
2730     }
2731
2732     if (@s) {
2733         my $s = join(" ", @s);
2734         $s =~ s/(.{50,60}) /$1\n#\t/g;
2735
2736         print
2737             "# The following locales\n#\n",
2738             "#\t", $s, "\n#\n",
2739             "# tested okay.\n#\n",
2740     } else {
2741         print "# None of your locales were fully okay.\n";
2742     }
2743
2744     if (@F) {
2745         my $F = join(" ", @F);
2746         $F =~ s/(.{50,60}) /$1\n#\t/g;
2747
2748         my $details = "";
2749         unless ($debug) {
2750             $details = "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2751         }
2752         elsif ($debug == 1) {
2753             $details = "# For even more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=2.\n";
2754         }
2755
2756         print
2757           "# The following locales\n#\n",
2758           "#\t", $F, "\n#\n",
2759           "# had problems.\n#\n",
2760           $details;
2761     } else {
2762         print "# None of your locales were broken.\n";
2763     }
2764 }
2765
2766 if (exists $known_bad_locales{$^O} && ! %Known_bad_locale) {
2767     $test_num++;
2768     print "ok $test_num $^O no longer has known bad locales # TODO\n";
2769 }
2770
2771 print "1..$test_num\n";
2772
2773 # eof