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