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