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