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