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.
8 # To make a TODO test, add the string 'TODO' to its %test_names value
10 my $is_ebcdic = ord("A") == 193;
12 no warnings 'locale'; # We test even weird locales; and do some scary things
15 binmode STDOUT, ':utf8';
16 binmode STDERR, ':utf8';
22 require './loc_tools.pl';
23 unless (locales_enabled('LC_CTYPE')) {
28 require Config; import Config;
32 use feature 'fc', 'postderef';
34 # =1 adds debugging output; =2 increases the verbosity somewhat
35 my $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
37 # Certain tests have been shown to be problematical for a few locales. Don't
38 # fail them unless at least this percentage of the tested locales fail.
39 # On AIX machines, many locales call a no-break space a graphic.
40 # (There aren't 1000 locales currently in existence, so 99.9 works)
41 my $acceptable_failure_percentage = ($^O =~ / ^ ( AIX ) $ /ix)
45 # The list of test numbers of the problematic tests.
46 my %problematical_tests;
48 # If any %problematical_tests fails in one of these locales, it is
50 my %known_bad_locales = (
51 irix => qr/ ^ (?: cs | hu | sk ) $/x,
52 darwin => qr/ ^ lt_LT.ISO8859 /ix,
53 os390 => qr/ ^ italian /ix,
56 # cygwin isn't returning proper radix length in this locale, but supposedly to
57 # be fixed in later versions.
58 if ($^O eq 'cygwin' && version->new(($Config{osvers} =~ /^(\d+(?:\.\d+)+)/)[0]) le v2.4.1) {
59 $known_bad_locales{'cygwin'} = qr/ ^ ps_AF /ix;
64 my $dumper = Dumpvalue->new(
71 my($mess) = join "", '# ', @_;
73 print STDERR $dumper->stringify($mess,1), "\n";
77 return unless $debug > 1;
82 printf STDERR @_ if $debug;
90 my ($result, $message) = @_;
91 $message = "" unless defined $message;
93 print 'not ' unless ($result);
94 print "ok " . ++$test_num;
97 return ($result) ? 1 : 0;
100 # First we'll do a lot of taint checking for locales.
101 # This is the easiest to test, actually, as any locale,
102 # even the default locale will taint under 'use locale'.
104 sub is_tainted { # hello, camel two.
105 no warnings 'uninitialized' ;
108 not eval { $dummy = join("", @_), kill 0; 1 }
111 sub check_taint ($;$) {
112 my $message_tail = $_[1] // "";
114 # Extra blanks are so aligns with taint_not output
115 $message_tail = ": $message_tail" if $message_tail;
116 ok is_tainted($_[0]), "verify that is tainted$message_tail";
119 sub check_taint_not ($;$) {
120 my $message_tail = $_[1] // "";
121 $message_tail = ": $message_tail" if $message_tail;
122 ok((not is_tainted($_[0])), "verify that isn't tainted$message_tail");
125 foreach my $category (qw(ALL COLLATE CTYPE MESSAGES MONETARY NUMERIC TIME)) {
126 my $short_result = locales_enabled($category);
127 ok ($short_result == 0 || $short_result == 1,
128 "Verify locales_enabled('$category') returns 0 or 1");
129 debug("locales_enabled('$category') returned '$short_result'");
130 my $long_result = locales_enabled("LC_$category");
131 if (! ok ($long_result == $short_result,
132 " and locales_enabled('LC_$category') returns "
135 debug("locales_enabled('LC_$category') returned $long_result");
139 "\tb\t" =~ /^m?(\s)(.*)\1$/;
140 check_taint_not $&, "not tainted outside 'use locale'";
143 use locale; # engage locale and therefore locale taint.
145 # BE SURE TO COPY ANYTHING YOU ADD to these tests to the block below for
148 check_taint_not $a, '$a';
150 check_taint uc($a), 'uc($a)';
151 check_taint "\U$a", '"\U$a"';
152 check_taint ucfirst($a), 'ucfirst($a)';
153 check_taint "\u$a", '"\u$a"';
154 check_taint lc($a), 'lc($a)';
155 check_taint fc($a), 'fc($a)';
156 check_taint "\L$a", '"\L$a"';
157 check_taint "\F$a", '"\F$a"';
158 check_taint lcfirst($a), 'lcfirst($a)';
159 check_taint "\l$a", '"\l$a"';
161 check_taint_not sprintf('%e', 123.456), "sprintf('%e', 123.456)";
162 check_taint_not sprintf('%f', 123.456), "sprintf('%f', 123.456)";
163 check_taint_not sprintf('%g', 123.456), "sprintf('%g', 123.456)";
164 check_taint_not sprintf('%d', 123.456), "sprintf('%d', 123.456)";
165 check_taint_not sprintf('%x', 123.456), "sprintf('%x', 123.456)";
167 $_ = $a; # untaint $_
169 $_ = uc($a); # taint $_
171 check_taint $_, '$_ = uc($a)';
173 /(\w)/; # taint $&, $`, $', $+, $1.
174 check_taint $&, "\$& from /(\\w)/";
175 check_taint $`, "\t\$`";
176 check_taint $', "\t\$'";
177 check_taint $+, "\t\$+";
178 check_taint $1, "\t\$1";
179 check_taint_not $2, "\t\$2";
181 /(.)/; # untaint $&, $`, $', $+, $1.
182 check_taint_not $&, "\$& from /(.)/";
183 check_taint_not $`, "\t\$`";
184 check_taint_not $', "\t\$'";
185 check_taint_not $+, "\t\$+";
186 check_taint_not $1, "\t\$1";
187 check_taint_not $2, "\t\$2";
189 /(\W)/; # taint $&, $`, $', $+, $1.
190 check_taint $&, "\$& from /(\\W)/";
191 check_taint $`, "\t\$`";
192 check_taint $', "\t\$'";
193 check_taint $+, "\t\$+";
194 check_taint $1, "\t\$1";
195 check_taint_not $2, "\t\$2";
197 /(.)/; # untaint $&, $`, $', $+, $1.
198 check_taint_not $&, "\$& from /(.)/";
199 check_taint_not $`, "\t\$`";
200 check_taint_not $', "\t\$'";
201 check_taint_not $+, "\t\$+";
202 check_taint_not $1, "\t\$1";
203 check_taint_not $2, "\t\$2";
205 /(\s)/; # taint $&, $`, $', $+, $1.
206 check_taint $&, "\$& from /(\\s)/";
207 check_taint $`, "\t\$`";
208 check_taint $', "\t\$'";
209 check_taint $+, "\t\$+";
210 check_taint $1, "\t\$1";
211 check_taint_not $2, "\t\$2";
213 /(.)/; # untaint $&, $`, $', $+, $1.
214 check_taint_not $&, "\$& from /(.)/";
216 /(\S)/; # taint $&, $`, $', $+, $1.
217 check_taint $&, "\$& from /(\\S)/";
218 check_taint $`, "\t\$`";
219 check_taint $', "\t\$'";
220 check_taint $+, "\t\$+";
221 check_taint $1, "\t\$1";
222 check_taint_not $2, "\t\$2";
224 /(.)/; # untaint $&, $`, $', $+, $1.
225 check_taint_not $&, "\$& from /(.)/";
227 "0" =~ /(\d)/; # taint $&, $`, $', $+, $1.
228 check_taint $&, "\$& from /(\\d)/";
229 check_taint $`, "\t\$`";
230 check_taint $', "\t\$'";
231 check_taint $+, "\t\$+";
232 check_taint $1, "\t\$1";
233 check_taint_not $2, "\t\$2";
235 /(.)/; # untaint $&, $`, $', $+, $1.
236 check_taint_not $&, "\$& from /(.)/";
238 /(\D)/; # taint $&, $`, $', $+, $1.
239 check_taint $&, "\$& from /(\\D)/";
240 check_taint $`, "\t\$`";
241 check_taint $', "\t\$'";
242 check_taint $+, "\t\$+";
243 check_taint $1, "\t\$1";
244 check_taint_not $2, "\t\$2";
246 /(.)/; # untaint $&, $`, $', $+, $1.
247 check_taint_not $&, "\$& from /(.)/";
249 /([[:alnum:]])/; # taint $&, $`, $', $+, $1.
250 check_taint $&, "\$& from /([[:alnum:]])/";
251 check_taint $`, "\t\$`";
252 check_taint $', "\t\$'";
253 check_taint $+, "\t\$+";
254 check_taint $1, "\t\$1";
255 check_taint_not $2, "\t\$2";
257 /(.)/; # untaint $&, $`, $', $+, $1.
258 check_taint_not $&, "\$& from /(.)/";
260 /([[:^alnum:]])/; # taint $&, $`, $', $+, $1.
261 check_taint $&, "\$& from /([[:^alnum:]])/";
262 check_taint $`, "\t\$`";
263 check_taint $', "\t\$'";
264 check_taint $+, "\t\$+";
265 check_taint $1, "\t\$1";
266 check_taint_not $2, "\t\$2";
268 "a" =~ /(a)|(\w)/; # taint $&, $`, $', $+, $1.
269 check_taint $&, "\$& from /(a)|(\\w)/";
270 check_taint $`, "\t\$`";
271 check_taint $', "\t\$'";
272 check_taint $+, "\t\$+";
273 check_taint $1, "\t\$1";
274 ok($1 eq 'a', ("\t" x 5) . "\$1 is 'a'");
275 ok(! defined $2, ("\t" x 5) . "\$2 is undefined");
276 check_taint_not $2, "\t\$2";
277 check_taint_not $3, "\t\$3";
279 /(.)/; # untaint $&, $`, $', $+, $1.
280 check_taint_not $&, "\$& from /(.)/";
282 "\N{CYRILLIC SMALL LETTER A}" =~ /(\N{CYRILLIC CAPITAL LETTER A})/i; # no tainting because no locale dependence
283 check_taint_not $&, "\$& from /(\\N{CYRILLIC CAPITAL LETTER A})/i";
284 check_taint_not $`, "\t\$`";
285 check_taint_not $', "\t\$'";
286 check_taint_not $+, "\t\$+";
287 check_taint_not $1, "\t\$1";
288 ok($1 eq "\N{CYRILLIC SMALL LETTER A}", ("\t" x 4) . "\t\$1 is 'small cyrillic a'");
289 check_taint_not $2, "\t\$2";
291 /(.)/; # untaint $&, $`, $', $+, $1.
292 check_taint_not $&, "\$& from /./";
294 "(\N{KELVIN SIGN})" =~ /(\N{KELVIN SIGN})/i; # taints because depends on locale
295 check_taint $&, "\$& from /(\\N{KELVIN SIGN})/i";
296 check_taint $`, "\t\$`";
297 check_taint $', "\t\$'";
298 check_taint $+, "\t\$+";
299 check_taint $1, "\t\$1";
300 check_taint_not $2, "\t\$2";
302 /(.)/; # untaint $&, $`, $', $+, $1.
303 check_taint_not $&, "\$& from /(.)/";
305 "a:" =~ /(.)\b(.)/; # taint $&, $`, $', $+, $1.
306 check_taint $&, "\$& from /(.)\\b(.)/";
307 check_taint $`, "\t\$`";
308 check_taint $', "\t\$'";
309 check_taint $+, "\t\$+";
310 check_taint $1, "\t\$1";
311 check_taint $2, "\t\$2";
312 check_taint_not $3, "\t\$3";
314 /(.)/; # untaint $&, $`, $', $+, $1.
315 check_taint_not $&, "\$& from /./";
317 "aa" =~ /(.)\B(.)/; # taint $&, $`, $', $+, $1.
318 check_taint $&, "\$& from /(.)\\B(.)/";
319 check_taint $`, "\t\$`";
320 check_taint $', "\t\$'";
321 check_taint $+, "\t\$+";
322 check_taint $1, "\t\$1";
323 check_taint $2, "\t\$2";
324 check_taint_not $3, "\t\$3";
326 /(.)/; # untaint $&, $`, $', $+, $1.
327 check_taint_not $&, "\$& from /./";
329 "aaa" =~ /(.).(\1)/i; # notaint because not locale dependent
330 check_taint_not $&, "\$ & from /(.).(\\1)/";
331 check_taint_not $`, "\t\$`";
332 check_taint_not $', "\t\$'";
333 check_taint_not $+, "\t\$+";
334 check_taint_not $1, "\t\$1";
335 check_taint_not $2, "\t\$2";
336 check_taint_not $3, "\t\$3";
338 /(.)/; # untaint $&, $`, $', $+, $1.
339 check_taint_not $&, "\$ & from /./";
341 $_ = $a; # untaint $_
343 check_taint_not $_, 'untainting $_ works';
345 /(b)/; # this must not taint
346 check_taint_not $&, "\$ & from /(b)/";
347 check_taint_not $`, "\t\$`";
348 check_taint_not $', "\t\$'";
349 check_taint_not $+, "\t\$+";
350 check_taint_not $1, "\t\$1";
351 check_taint_not $2, "\t\$2";
353 $_ = $a; # untaint $_
355 check_taint_not $_, 'untainting $_ works';
357 $b = uc($a); # taint $b
358 s/(.+)/$b/; # this must taint only the $_
360 check_taint $_, '$_ (wasn\'t tainted) from s/(.+)/$b/ where $b is tainted';
361 check_taint_not $&, "\t\$&";
362 check_taint_not $`, "\t\$`";
363 check_taint_not $', "\t\$'";
364 check_taint_not $+, "\t\$+";
365 check_taint_not $1, "\t\$1";
366 check_taint_not $2, "\t\$2";
368 $_ = $a; # untaint $_
370 s/(.+)/b/; # this must not taint
371 check_taint_not $_, '$_ (wasn\'t tainted) from s/(.+)/b/';
372 check_taint_not $&, "\t\$&";
373 check_taint_not $`, "\t\$`";
374 check_taint_not $', "\t\$'";
375 check_taint_not $+, "\t\$+";
376 check_taint_not $1, "\t\$1";
377 check_taint_not $2, "\t\$2";
379 $b = $a; # untaint $b
381 ($b = $a) =~ s/\w/$&/;
382 check_taint $b, '$b from ($b = $a) =~ s/\w/$&/'; # $b should be tainted.
383 check_taint_not $a, '$a from ($b = $a) =~ s/\w/$&/'; # $a should be not.
385 $_ = $a; # untaint $_
387 s/(\w)/\l$1/; # this must taint
388 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\l$1/,'; # this must taint
389 check_taint $&, "\t\$&";
390 check_taint $`, "\t\$`";
391 check_taint $', "\t\$'";
392 check_taint $+, "\t\$+";
393 check_taint $1, "\t\$1";
394 check_taint_not $2, "\t\$2";
396 $_ = $a; # untaint $_
398 s/(\w)/\L$1/; # this must taint
399 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\L$1/,';
400 check_taint $&, "\t\$&";
401 check_taint $`, "\t\$`";
402 check_taint $', "\t\$'";
403 check_taint $+, "\t\$+";
404 check_taint $1, "\t\$1";
405 check_taint_not $2, "\t\$2";
407 $_ = $a; # untaint $_
409 s/(\w)/\u$1/; # this must taint
410 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\u$1/';
411 check_taint $&, "\t\$&";
412 check_taint $`, "\t\$`";
413 check_taint $', "\t\$'";
414 check_taint $+, "\t\$+";
415 check_taint $1, "\t\$1";
416 check_taint_not $2, "\t\$2";
418 $_ = $a; # untaint $_
420 s/(\w)/\U$1/; # this must taint
421 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\U$1/';
422 check_taint $&, "\t\$&";
423 check_taint $`, "\t\$`";
424 check_taint $', "\t\$'";
425 check_taint $+, "\t\$+";
426 check_taint $1, "\t\$1";
427 check_taint_not $2, "\t\$2";
429 # After all this tainting $a should be cool.
431 check_taint_not $a, '$a still not tainted';
434 check_taint_not $1, '"a" =~ /([a-z])/';
435 "foo.bar_baz" =~ /^(.*)[._](.*?)$/; # Bug 120675
436 check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
438 # BE SURE TO COPY ANYTHING YOU ADD to the block below
440 { # This is just the previous tests copied here with a different
441 # compile-time pragma.
443 use locale ':not_characters'; # engage restricted locale with different
445 check_taint_not $a, '$a';
447 check_taint_not uc($a), 'uc($a)';
448 check_taint_not "\U$a", '"\U$a"';
449 check_taint_not ucfirst($a), 'ucfirst($a)';
450 check_taint_not "\u$a", '"\u$a"';
451 check_taint_not lc($a), 'lc($a)';
452 check_taint_not fc($a), 'fc($a)';
453 check_taint_not "\L$a", '"\L$a"';
454 check_taint_not "\F$a", '"\F$a"';
455 check_taint_not lcfirst($a), 'lcfirst($a)';
456 check_taint_not "\l$a", '"\l$a"';
458 check_taint_not sprintf('%e', 123.456), "sprintf('%e', 123.456)";
459 check_taint_not sprintf('%f', 123.456), "sprintf('%f', 123.456)";
460 check_taint_not sprintf('%g', 123.456), "sprintf('%g', 123.456)";
461 check_taint_not sprintf('%d', 123.456), "sprintf('%d', 123.456)";
462 check_taint_not sprintf('%x', 123.456), "sprintf('%x', 123.456)";
464 $_ = $a; # untaint $_
468 check_taint_not $_, '$_ = uc($a)';
471 check_taint_not $&, "\$& from /(\\w)/";
472 check_taint_not $`, "\t\$`";
473 check_taint_not $', "\t\$'";
474 check_taint_not $+, "\t\$+";
475 check_taint_not $1, "\t\$1";
476 check_taint_not $2, "\t\$2";
478 /(.)/; # untaint $&, $`, $', $+, $1.
479 check_taint_not $&, "\$& from /(.)/";
480 check_taint_not $`, "\t\$`";
481 check_taint_not $', "\t\$'";
482 check_taint_not $+, "\t\$+";
483 check_taint_not $1, "\t\$1";
484 check_taint_not $2, "\t\$2";
487 check_taint_not $&, "\$& from /(\\W)/";
488 check_taint_not $`, "\t\$`";
489 check_taint_not $', "\t\$'";
490 check_taint_not $+, "\t\$+";
491 check_taint_not $1, "\t\$1";
492 check_taint_not $2, "\t\$2";
494 /(.)/; # untaint $&, $`, $', $+, $1.
495 check_taint_not $&, "\$& from /(.)/";
496 check_taint_not $`, "\t\$`";
497 check_taint_not $', "\t\$'";
498 check_taint_not $+, "\t\$+";
499 check_taint_not $1, "\t\$1";
500 check_taint_not $2, "\t\$2";
503 check_taint_not $&, "\$& from /(\\s)/";
504 check_taint_not $`, "\t\$`";
505 check_taint_not $', "\t\$'";
506 check_taint_not $+, "\t\$+";
507 check_taint_not $1, "\t\$1";
508 check_taint_not $2, "\t\$2";
510 /(.)/; # untaint $&, $`, $', $+, $1.
511 check_taint_not $&, "\$& from /(.)/";
514 check_taint_not $&, "\$& from /(\\S)/";
515 check_taint_not $`, "\t\$`";
516 check_taint_not $', "\t\$'";
517 check_taint_not $+, "\t\$+";
518 check_taint_not $1, "\t\$1";
519 check_taint_not $2, "\t\$2";
521 /(.)/; # untaint $&, $`, $', $+, $1.
522 check_taint_not $&, "\$& from /(.)/";
525 check_taint_not $&, "\$& from /(\\d)/";
526 check_taint_not $`, "\t\$`";
527 check_taint_not $', "\t\$'";
528 check_taint_not $+, "\t\$+";
529 check_taint_not $1, "\t\$1";
530 check_taint_not $2, "\t\$2";
532 /(.)/; # untaint $&, $`, $', $+, $1.
533 check_taint_not $&, "\$& from /(.)/";
536 check_taint_not $&, "\$& from /(\\D)/";
537 check_taint_not $`, "\t\$`";
538 check_taint_not $', "\t\$'";
539 check_taint_not $+, "\t\$+";
540 check_taint_not $1, "\t\$1";
541 check_taint_not $2, "\t\$2";
543 /(.)/; # untaint $&, $`, $', $+, $1.
544 check_taint_not $&, "\$& from /(.)/";
547 check_taint_not $&, "\$& from /([[:alnum:]])/";
548 check_taint_not $`, "\t\$`";
549 check_taint_not $', "\t\$'";
550 check_taint_not $+, "\t\$+";
551 check_taint_not $1, "\t\$1";
552 check_taint_not $2, "\t\$2";
554 /(.)/; # untaint $&, $`, $', $+, $1.
555 check_taint_not $&, "\$& from /(.)/";
558 check_taint_not $&, "\$& from /([[:^alnum:]])/";
559 check_taint_not $`, "\t\$`";
560 check_taint_not $', "\t\$'";
561 check_taint_not $+, "\t\$+";
562 check_taint_not $1, "\t\$1";
563 check_taint_not $2, "\t\$2";
566 check_taint_not $&, "\$& from /(a)|(\\w)/";
567 check_taint_not $`, "\t\$`";
568 check_taint_not $', "\t\$'";
569 check_taint_not $+, "\t\$+";
570 check_taint_not $1, "\t\$1";
571 ok($1 eq 'a', ("\t" x 5) . "\$1 is 'a'");
572 ok(! defined $2, ("\t" x 5) . "\$2 is undefined");
573 check_taint_not $2, "\t\$2";
574 check_taint_not $3, "\t\$3";
576 /(.)/; # untaint $&, $`, $', $+, $1.
577 check_taint_not $&, "\$& from /(.)/";
579 "\N{CYRILLIC SMALL LETTER A}" =~ /(\N{CYRILLIC CAPITAL LETTER A})/i;
580 check_taint_not $&, "\$& from /(\\N{CYRILLIC CAPITAL LETTER A})/i";
581 check_taint_not $`, "\t\$`";
582 check_taint_not $', "\t\$'";
583 check_taint_not $+, "\t\$+";
584 check_taint_not $1, "\t\$1";
585 ok($1 eq "\N{CYRILLIC SMALL LETTER A}", ("\t" x 4) . "\t\$1 is 'small cyrillic a'");
586 check_taint_not $2, "\t\$2";
588 /(.)/; # untaint $&, $`, $', $+, $1.
589 check_taint_not $&, "\$& from /./";
591 "(\N{KELVIN SIGN})" =~ /(\N{KELVIN SIGN})/i;
592 check_taint_not $&, "\$& from /(\\N{KELVIN SIGN})/i";
593 check_taint_not $`, "\t\$`";
594 check_taint_not $', "\t\$'";
595 check_taint_not $+, "\t\$+";
596 check_taint_not $1, "\t\$1";
597 check_taint_not $2, "\t\$2";
599 /(.)/; # untaint $&, $`, $', $+, $1.
600 check_taint_not $&, "\$& from /(.)/";
603 check_taint_not $&, "\$& from /(.)\\b(.)/";
604 check_taint_not $`, "\t\$`";
605 check_taint_not $', "\t\$'";
606 check_taint_not $+, "\t\$+";
607 check_taint_not $1, "\t\$1";
608 check_taint_not $2, "\t\$2";
609 check_taint_not $3, "\t\$3";
611 /(.)/; # untaint $&, $`, $', $+, $1.
612 check_taint_not $&, "\$& from /./";
615 check_taint_not $&, "\$& from /(.)\\B(.)/";
616 check_taint_not $`, "\t\$`";
617 check_taint_not $', "\t\$'";
618 check_taint_not $+, "\t\$+";
619 check_taint_not $1, "\t\$1";
620 check_taint_not $2, "\t\$2";
621 check_taint_not $3, "\t\$3";
623 /(.)/; # untaint $&, $`, $', $+, $1.
624 check_taint_not $&, "\$& from /./";
626 "aaa" =~ /(.).(\1)/i; # notaint because not locale dependent
627 check_taint_not $&, "\$ & from /(.).(\\1)/";
628 check_taint_not $`, "\t\$`";
629 check_taint_not $', "\t\$'";
630 check_taint_not $+, "\t\$+";
631 check_taint_not $1, "\t\$1";
632 check_taint_not $2, "\t\$2";
633 check_taint_not $3, "\t\$3";
635 /(.)/; # untaint $&, $`, $', $+, $1.
636 check_taint_not $&, "\$ & from /./";
638 $_ = $a; # untaint $_
640 check_taint_not $_, 'untainting $_ works';
643 check_taint_not $&, "\$ & from /(b)/";
644 check_taint_not $`, "\t\$`";
645 check_taint_not $', "\t\$'";
646 check_taint_not $+, "\t\$+";
647 check_taint_not $1, "\t\$1";
648 check_taint_not $2, "\t\$2";
650 $_ = $a; # untaint $_
652 check_taint_not $_, 'untainting $_ works';
655 check_taint_not $_, '$_ (wasn\'t tainted) from s/(.+)/b/';
656 check_taint_not $&, "\t\$&";
657 check_taint_not $`, "\t\$`";
658 check_taint_not $', "\t\$'";
659 check_taint_not $+, "\t\$+";
660 check_taint_not $1, "\t\$1";
661 check_taint_not $2, "\t\$2";
663 $b = $a; # untaint $b
665 ($b = $a) =~ s/\w/$&/;
666 check_taint_not $b, '$b from ($b = $a) =~ s/\w/$&/';
667 check_taint_not $a, '$a from ($b = $a) =~ s/\w/$&/';
669 $_ = $a; # untaint $_
672 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\l$1/,'; # this must taint
673 check_taint_not $&, "\t\$&";
674 check_taint_not $`, "\t\$`";
675 check_taint_not $', "\t\$'";
676 check_taint_not $+, "\t\$+";
677 check_taint_not $1, "\t\$1";
678 check_taint_not $2, "\t\$2";
680 $_ = $a; # untaint $_
683 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\L$1/,';
684 check_taint_not $&, "\t\$&";
685 check_taint_not $`, "\t\$`";
686 check_taint_not $', "\t\$'";
687 check_taint_not $+, "\t\$+";
688 check_taint_not $1, "\t\$1";
689 check_taint_not $2, "\t\$2";
691 $_ = $a; # untaint $_
694 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\u$1/';
695 check_taint_not $&, "\t\$&";
696 check_taint_not $`, "\t\$`";
697 check_taint_not $', "\t\$'";
698 check_taint_not $+, "\t\$+";
699 check_taint_not $1, "\t\$1";
700 check_taint_not $2, "\t\$2";
702 $_ = $a; # untaint $_
705 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\U$1/';
706 check_taint_not $&, "\t\$&";
707 check_taint_not $`, "\t\$`";
708 check_taint_not $', "\t\$'";
709 check_taint_not $+, "\t\$+";
710 check_taint_not $1, "\t\$1";
711 check_taint_not $2, "\t\$2";
713 # After all this tainting $a should be cool.
715 check_taint_not $a, '$a still not tainted';
718 check_taint_not $1, '"a" =~ /([a-z])/';
719 "foo.bar_baz" =~ /^(.*)[._](.*?)$/; # Bug 120675
720 check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
724 # Here are in scope of 'use locale'
726 # I think we've seen quite enough of taint.
727 # Let us do some *real* locale work now,
728 # unless setlocale() is missing (i.e. minitest).
730 # The test number before our first setlocale()
731 my $final_without_setlocale = $test_num;
735 debug "Scanning for locales...\n";
737 require POSIX; import POSIX ':locale_h';
739 my @Locale = find_locales([ &POSIX::LC_CTYPE, &POSIX::LC_NUMERIC, &POSIX::LC_ALL ]);
747 print "1..$test_num\n";
752 setlocale(&POSIX::LC_ALL, "C");
758 my %Known_bad_locale; # Failed test for a locale known to be bad
760 my @Added_alpha; # Alphas that aren't in the C locale.
764 # This returns a display string denoting the input parameter @_, each
765 # entry of which is a single character in the range 0-255. The first part
766 # of the output is a string of the characters in @_ that are ASCII
767 # graphics, and hence unambiguously displayable. They are given by code
768 # point order. The second part is the remaining code points, the ordinals
769 # of which are each displayed as 2-digit hex. Blanks are inserted so as
770 # to keep anything from the first part looking like a 2-digit hex number.
773 my @chars = sort { ord $a <=> ord $b } @_;
777 push @chars, chr(258); # This sentinel simplifies the loop termination
779 foreach my $i (0 .. @chars - 1) {
780 my $char = $chars[$i];
784 # We avoid using [:posix:] classes, as these are being tested in this
785 # file. Each equivalence class below is for things that can appear in
786 # a range; those that can't be in a range have class -1. 0 for those
787 # which should be output in hex; and >0 for the other ranges
788 if ($char =~ /[A-Z]/) {
791 elsif ($char =~ /[a-z]/) {
794 elsif ($char =~ /[0-9]/) {
797 # Uncomment to get literal punctuation displayed instead of hex
798 #elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
799 # $class = -1; # Punct never appears in a range
802 $class = 0; # Output in hex
805 if (! defined $range_start) {
807 $output .= " " . $char;
810 $range_start = ord $char;
811 $start_class = $class;
813 } # A range ends if not consecutive, or the class-type changes
814 elsif (ord $char != ($range_end = ord($chars[$i-1])) + 1
815 || $class != $start_class)
818 # Here, the current character is not in the range. This means the
819 # previous character must have been. Output the range up through
821 my $range_length = $range_end - $range_start + 1;
822 if ($start_class > 0) {
823 $output .= " " . chr($range_start);
824 $output .= "-" . chr($range_end) if $range_length > 1;
827 $output .= sprintf(" %02X", $range_start);
828 $output .= sprintf("-%02X", $range_end) if $range_length > 1;
831 # Handle the new current character, as potentially beginning a new
845 # Displays the string unambiguously. ASCII printables are always output
846 # as-is, though perhaps separated by blanks from other characters. If
847 # entirely printable ASCII, just returns the string. Otherwise if valid
848 # UTF-8 it uses the character names for non-printable-ASCII. Otherwise it
849 # outputs hex for each non-ASCII-printable byte.
851 return $string if $string =~ / ^ [[:print:]]* $/xa;
854 my $prev_was_punct = 1; # Beginning is considered punct
855 if (utf8::valid($string) && utf8::is_utf8($string)) {
857 foreach my $char (split "", $string) {
859 # Keep punctuation adjacent to other characters; otherwise
860 # separate them with a blank
861 if ($char =~ /[[:punct:]]/a) {
865 elsif ($char =~ /[[:print:]]/a) {
866 $result .= " " unless $prev_was_punct;
871 $result .= " " unless $prev_was_punct;
872 my $name = charnames::viacode(ord $char);
873 $result .= (defined $name) ? $name : ':unknown:';
880 foreach my $char (split "", $string) {
881 if ($char =~ /[[:punct:]]/a) {
885 elsif ($char =~ /[[:print:]]/a) {
886 $result .= " " unless $prev_was_punct;
891 $result .= " " unless $prev_was_punct;
892 $result .= sprintf("%02X", ord $char);
902 my ($Locale, $i, $pass_fail, $message) = @_;
904 $message = " ($message)" if $message;
906 push @{$Okay{$i}}, $Locale;
909 $Known_bad_locale{$i}{$Locale} = 1 if exists $known_bad_locales{$^O}
910 && $Locale =~ $known_bad_locales{$^O};
911 $Problem{$i}{$Locale} = 1;
912 debug "failed $i ($test_names{$i}) with locale '$Locale'$message\n";
916 sub report_multi_result {
917 my ($Locale, $i, $results_ref) = @_;
919 # $results_ref points to an array, each element of which is a character that was
920 # in error for this test numbered '$i'. If empty, the test passed
924 $message = join " ", "for", disp_chars(@$results_ref);
926 report_result($Locale, $i, @$results_ref == 0, $message);
929 my $first_locales_test_number = $final_without_setlocale + 1;
930 my $locales_test_number;
931 my $not_necessarily_a_problem_test_number;
932 my $first_casing_test_number;
933 my %setlocale_failed; # List of locales that setlocale() didn't work on
935 foreach my $Locale (@Locale) {
936 $locales_test_number = $first_locales_test_number - 1;
938 debug "Locale = $Locale\n";
940 unless (setlocale(&POSIX::LC_ALL, $Locale)) {
941 $setlocale_failed{$Locale} = $Locale;
945 # We test UTF-8 locales only under ':not_characters'; It is easier to
946 # test them in other test files than here. Non- UTF-8 locales are tested
947 # only under plain 'use locale', as otherwise we would have to convert
948 # everything in them to Unicode.
950 my %UPPER = (); # All alpha X for which uc(X) == X and lc(X) != X
951 my %lower = (); # All alpha X for which lc(X) == X and uc(X) != X
952 my %BoThCaSe = (); # All alpha X for which uc(X) == lc(X) == X
954 my $is_utf8_locale = is_locale_utf8($Locale);
956 debug "is utf8 locale? = $is_utf8_locale\n";
958 debug "radix = " . disp_str(localeconv()->{decimal_point}) . "\n";
960 if (! $is_utf8_locale) {
962 @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
963 @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
964 @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
965 @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
966 @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
967 @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
968 @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
969 @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
970 @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
971 @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
972 @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
973 @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
974 @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
975 @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
976 @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
978 # Sieve the uppercase and the lowercase.
980 for (@{$posixes{'word'}}) {
981 if (/[^\d_]/) { # skip digits and the _
992 use locale ':not_characters';
993 @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
994 @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
995 @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
996 @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
997 @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
998 @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
999 @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
1000 @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
1001 @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
1002 @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
1003 @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
1004 @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
1005 @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
1006 @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
1007 @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
1008 for (@{$posixes{'word'}}) {
1009 if (/[^\d_]/) { # skip digits and the _
1020 # Ordered, where possible, in groups of "this is a subset of the next
1022 debug ":upper: = ", disp_chars(@{$posixes{'upper'}}), "\n";
1023 debug ":lower: = ", disp_chars(@{$posixes{'lower'}}), "\n";
1024 debug ":cased: = ", disp_chars(@{$posixes{'cased'}}), "\n";
1025 debug ":alpha: = ", disp_chars(@{$posixes{'alpha'}}), "\n";
1026 debug ":alnum: = ", disp_chars(@{$posixes{'alnum'}}), "\n";
1027 debug " w = ", disp_chars(@{$posixes{'word'}}), "\n";
1028 debug ":graph: = ", disp_chars(@{$posixes{'graph'}}), "\n";
1029 debug ":print: = ", disp_chars(@{$posixes{'print'}}), "\n";
1030 debug " d = ", disp_chars(@{$posixes{'digit'}}), "\n";
1031 debug ":xdigit: = ", disp_chars(@{$posixes{'xdigit'}}), "\n";
1032 debug ":blank: = ", disp_chars(@{$posixes{'blank'}}), "\n";
1033 debug " s = ", disp_chars(@{$posixes{'space'}}), "\n";
1034 debug ":punct: = ", disp_chars(@{$posixes{'punct'}}), "\n";
1035 debug ":cntrl: = ", disp_chars(@{$posixes{'cntrl'}}), "\n";
1036 debug ":ascii: = ", disp_chars(@{$posixes{'ascii'}}), "\n";
1038 foreach (keys %UPPER) {
1040 $BoThCaSe{$_}++ if exists $lower{$_};
1042 foreach (keys %lower) {
1043 $BoThCaSe{$_}++ if exists $UPPER{$_};
1045 foreach (keys %BoThCaSe) {
1051 foreach my $ord ( 0 .. 255 ) {
1052 $Unassigned{chr $ord} = 1;
1054 foreach my $class (keys %posixes) {
1055 foreach my $char (@{$posixes{$class}}) {
1056 delete $Unassigned{$char};
1060 debug "UPPER = ", disp_chars(sort { ord $a <=> ord $b } keys %UPPER), "\n";
1061 debug "lower = ", disp_chars(sort { ord $a <=> ord $b } keys %lower), "\n";
1062 debug "BoThCaSe = ", disp_chars(sort { ord $a <=> ord $b } keys %BoThCaSe), "\n";
1063 debug "Unassigned = ", disp_chars(sort { ord $a <=> ord $b } keys %Unassigned), "\n";
1067 foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
1070 if ($is_utf8_locale) {
1071 use locale ':not_characters';
1072 $ok = $x =~ /[[:upper:]]/;
1073 $fold_ok = $x =~ /[[:lower:]]/i;
1077 $ok = $x =~ /[[:upper:]]/;
1078 $fold_ok = $x =~ /[[:lower:]]/i;
1080 push @failures, $x unless $ok;
1081 push @fold_failures, $x unless $fold_ok;
1083 $locales_test_number++;
1084 $first_casing_test_number = $locales_test_number;
1085 $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
1086 report_multi_result($Locale, $locales_test_number, \@failures);
1088 $locales_test_number++;
1090 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
1091 report_multi_result($Locale, $locales_test_number, \@fold_failures);
1094 undef @fold_failures;
1096 foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
1099 if ($is_utf8_locale) {
1100 use locale ':not_characters';
1101 $ok = $x =~ /[[:lower:]]/;
1102 $fold_ok = $x =~ /[[:upper:]]/i;
1106 $ok = $x =~ /[[:lower:]]/;
1107 $fold_ok = $x =~ /[[:upper:]]/i;
1109 push @failures, $x unless $ok;
1110 push @fold_failures, $x unless $fold_ok;
1113 $locales_test_number++;
1114 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
1115 report_multi_result($Locale, $locales_test_number, \@failures);
1117 $locales_test_number++;
1118 $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
1119 report_multi_result($Locale, $locales_test_number, \@fold_failures);
1121 { # Find the alphabetic characters that are not considered alphabetics
1122 # in the default (C) locale.
1127 for (keys %UPPER, keys %lower, keys %BoThCaSe) {
1128 push(@Added_alpha, $_) if (/\W/);
1132 @Added_alpha = sort { ord $a <=> ord $b } @Added_alpha;
1134 debug "Added_alpha = ", disp_chars(@Added_alpha), "\n";
1136 # Cross-check the whole 8-bit character set.
1138 ++$locales_test_number;
1140 $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
1141 for (map { chr } 0..255) {
1142 if ($is_utf8_locale) {
1143 use locale ':not_characters';
1144 push @f, $_ unless /[[:word:]]/ == /\w/;
1147 push @f, $_ unless /[[:word:]]/ == /\w/;
1150 report_multi_result($Locale, $locales_test_number, \@f);
1152 ++$locales_test_number;
1154 $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1155 for (map { chr } 0..255) {
1156 if ($is_utf8_locale) {
1157 use locale ':not_characters';
1158 push @f, $_ unless /[[:digit:]]/ == /\d/;
1161 push @f, $_ unless /[[:digit:]]/ == /\d/;
1164 report_multi_result($Locale, $locales_test_number, \@f);
1166 ++$locales_test_number;
1168 $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1169 for (map { chr } 0..255) {
1170 if ($is_utf8_locale) {
1171 use locale ':not_characters';
1172 push @f, $_ unless /[[:space:]]/ == /\s/;
1175 push @f, $_ unless /[[:space:]]/ == /\s/;
1178 report_multi_result($Locale, $locales_test_number, \@f);
1180 ++$locales_test_number;
1182 $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1183 for (map { chr } 0..255) {
1184 if ($is_utf8_locale) {
1185 use locale ':not_characters';
1186 push @f, $_ unless (/[[:alpha:]]/ xor /[[:^alpha:]]/) ||
1187 (/[[:alnum:]]/ xor /[[:^alnum:]]/) ||
1188 (/[[:ascii:]]/ xor /[[:^ascii:]]/) ||
1189 (/[[:blank:]]/ xor /[[:^blank:]]/) ||
1190 (/[[:cntrl:]]/ xor /[[:^cntrl:]]/) ||
1191 (/[[:digit:]]/ xor /[[:^digit:]]/) ||
1192 (/[[:graph:]]/ xor /[[:^graph:]]/) ||
1193 (/[[:lower:]]/ xor /[[:^lower:]]/) ||
1194 (/[[:print:]]/ xor /[[:^print:]]/) ||
1195 (/[[:space:]]/ xor /[[:^space:]]/) ||
1196 (/[[:upper:]]/ xor /[[:^upper:]]/) ||
1197 (/[[:word:]]/ xor /[[:^word:]]/) ||
1198 (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1200 # effectively is what [:cased:] would be if it existed.
1201 (/[[:upper:]]/i xor /[[:^upper:]]/i);
1204 push @f, $_ unless (/[[:alpha:]]/ xor /[[:^alpha:]]/) ||
1205 (/[[:alnum:]]/ xor /[[:^alnum:]]/) ||
1206 (/[[:ascii:]]/ xor /[[:^ascii:]]/) ||
1207 (/[[:blank:]]/ xor /[[:^blank:]]/) ||
1208 (/[[:cntrl:]]/ xor /[[:^cntrl:]]/) ||
1209 (/[[:digit:]]/ xor /[[:^digit:]]/) ||
1210 (/[[:graph:]]/ xor /[[:^graph:]]/) ||
1211 (/[[:lower:]]/ xor /[[:^lower:]]/) ||
1212 (/[[:print:]]/ xor /[[:^print:]]/) ||
1213 (/[[:space:]]/ xor /[[:^space:]]/) ||
1214 (/[[:upper:]]/ xor /[[:^upper:]]/) ||
1215 (/[[:word:]]/ xor /[[:^word:]]/) ||
1216 (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1217 (/[[:upper:]]/i xor /[[:^upper:]]/i);
1220 report_multi_result($Locale, $locales_test_number, \@f);
1222 # The rules for the relationships are given in:
1223 # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1226 ++$locales_test_number;
1228 $test_names{$locales_test_number} = 'Verify that [:lower:] contains at least a-z';
1230 if ($is_utf8_locale) {
1231 use locale ':not_characters';
1232 push @f, $_ unless /[[:lower:]]/;
1235 push @f, $_ unless /[[:lower:]]/;
1238 report_multi_result($Locale, $locales_test_number, \@f);
1240 ++$locales_test_number;
1242 $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1243 for (map { chr } 0..255) {
1244 if ($is_utf8_locale) {
1245 use locale ':not_characters';
1246 push @f, $_ if /[[:lower:]]/ and ! /[[:alpha:]]/;
1249 push @f, $_ if /[[:lower:]]/ and ! /[[:alpha:]]/;
1252 report_multi_result($Locale, $locales_test_number, \@f);
1254 ++$locales_test_number;
1256 $test_names{$locales_test_number} = 'Verify that [:upper:] contains at least A-Z';
1258 if ($is_utf8_locale) {
1259 use locale ':not_characters';
1260 push @f, $_ unless /[[:upper:]]/;
1263 push @f, $_ unless /[[:upper:]]/;
1266 report_multi_result($Locale, $locales_test_number, \@f);
1268 ++$locales_test_number;
1270 $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1271 for (map { chr } 0..255) {
1272 if ($is_utf8_locale) {
1273 use locale ':not_characters';
1274 push @f, $_ if /[[:upper:]]/ and ! /[[:alpha:]]/;
1277 push @f, $_ if /[[:upper:]]/ and ! /[[:alpha:]]/;
1280 report_multi_result($Locale, $locales_test_number, \@f);
1282 ++$locales_test_number;
1284 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1285 for (map { chr } 0..255) {
1286 if ($is_utf8_locale) {
1287 use locale ':not_characters';
1288 push @f, $_ if /[[:lower:]]/i and ! /[[:alpha:]]/;
1291 push @f, $_ if /[[:lower:]]/i and ! /[[:alpha:]]/;
1294 report_multi_result($Locale, $locales_test_number, \@f);
1296 ++$locales_test_number;
1298 $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1299 for (map { chr } 0..255) {
1300 if ($is_utf8_locale) {
1301 use locale ':not_characters';
1302 push @f, $_ if /[[:alpha:]]/ and ! /[[:alnum:]]/;
1305 push @f, $_ if /[[:alpha:]]/ and ! /[[:alnum:]]/;
1308 report_multi_result($Locale, $locales_test_number, \@f);
1310 ++$locales_test_number;
1312 $test_names{$locales_test_number} = 'Verify that [:digit:] contains at least 0-9';
1314 if ($is_utf8_locale) {
1315 use locale ':not_characters';
1316 push @f, $_ unless /[[:digit:]]/;
1319 push @f, $_ unless /[[:digit:]]/;
1322 report_multi_result($Locale, $locales_test_number, \@f);
1324 ++$locales_test_number;
1326 $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1327 for (map { chr } 0..255) {
1328 if ($is_utf8_locale) {
1329 use locale ':not_characters';
1330 push @f, $_ if /[[:digit:]]/ and ! /[[:alnum:]]/;
1333 push @f, $_ if /[[:digit:]]/ and ! /[[:alnum:]]/;
1336 report_multi_result($Locale, $locales_test_number, \@f);
1338 ++$locales_test_number;
1340 $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1341 report_result($Locale, $locales_test_number, @{$posixes{'digit'}} == 10 || @{$posixes{'digit'}} == 20);
1343 ++$locales_test_number;
1345 $test_names{$locales_test_number} = 'Verify that if there is a second set of digits in [:digit:], they are consecutive';
1346 if (@{$posixes{'digit'}} == 20) {
1348 for (map { chr } 0..255) {
1349 next unless /[[:digit:]]/;
1351 if (defined $previous_ord) {
1352 if ($is_utf8_locale) {
1353 use locale ':not_characters';
1354 push @f, $_ if ord $_ != $previous_ord + 1;
1357 push @f, $_ if ord $_ != $previous_ord + 1;
1360 $previous_ord = ord $_;
1363 report_multi_result($Locale, $locales_test_number, \@f);
1365 ++$locales_test_number;
1367 my @xdigit_digits; # :digit: & :xdigit:
1368 $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains one or two blocks of 10 consecutive [:digit:] chars';
1369 for (map { chr } 0..255) {
1370 if ($is_utf8_locale) {
1371 use locale ':not_characters';
1372 # For utf8 locales, we actually use a stricter test: that :digit:
1373 # is a subset of :xdigit:, as we know that only 0-9 should match
1374 push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
1377 push @xdigit_digits, $_ if /[[:digit:]]/ and /[[:xdigit:]]/;
1380 if (! $is_utf8_locale) {
1382 # For non-utf8 locales, @xdigit_digits is a list of the characters
1383 # that are both :xdigit: and :digit:. Because :digit: is stored in
1384 # increasing code point order (unless the tests above failed),
1385 # @xdigit_digits is as well. There should be exactly 10 or
1387 if (@xdigit_digits != 10 && @xdigit_digits != 20) {
1388 @f = @xdigit_digits;
1392 # Look for contiguity in the series, adding any wrong ones to @f
1393 my @temp = @xdigit_digits;
1395 push @f, $temp[1] if ($temp[0] != $temp[1] - 1)
1397 # Skip this test for the 0th character of
1398 # the second block of 10, as it won't be
1399 # contiguous with the previous block
1400 && (! defined $xdigit_digits[10]
1401 || $temp[1] != $xdigit_digits[10]);
1407 report_multi_result($Locale, $locales_test_number, \@f);
1409 ++$locales_test_number;
1411 $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains at least A-F, a-f';
1412 for ('A' .. 'F', 'a' .. 'f') {
1413 if ($is_utf8_locale) {
1414 use locale ':not_characters';
1415 push @f, $_ unless /[[:xdigit:]]/;
1418 push @f, $_ unless /[[:xdigit:]]/;
1421 report_multi_result($Locale, $locales_test_number, \@f);
1423 ++$locales_test_number;
1425 $test_names{$locales_test_number} = 'Verify that any additional members of [:xdigit:], are in groups of 6 consecutive code points';
1428 for my $chr (map { chr } 0..255) {
1429 next unless $chr =~ /[[:xdigit:]]/;
1430 if ($is_utf8_locale) {
1431 next if $chr =~ /[[:digit:]]/;
1434 next if grep { $chr eq $_ } @xdigit_digits;
1436 next if $chr =~ /[A-Fa-f]/;
1437 if (defined $previous_ord) {
1438 if ($is_utf8_locale) {
1439 use locale ':not_characters';
1440 push @f, $chr if ord $chr != $previous_ord + 1;
1443 push @f, $chr if ord $chr != $previous_ord + 1;
1448 undef $previous_ord;
1451 $previous_ord = ord $chr;
1454 report_multi_result($Locale, $locales_test_number, \@f);
1456 ++$locales_test_number;
1458 $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1459 for (map { chr } 0..255) {
1460 if ($is_utf8_locale) {
1461 use locale ':not_characters';
1462 push @f, $_ if /[[:xdigit:]]/ and ! /[[:graph:]]/;
1465 push @f, $_ if /[[:xdigit:]]/ and ! /[[:graph:]]/;
1468 report_multi_result($Locale, $locales_test_number, \@f);
1470 # Note that xdigit doesn't have to be a subset of alnum
1472 ++$locales_test_number;
1474 $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1475 for (map { chr } 0..255) {
1476 if ($is_utf8_locale) {
1477 use locale ':not_characters';
1478 push @f, $_ if /[[:punct:]]/ and ! /[[:graph:]]/;
1481 push @f, $_ if /[[:punct:]]/ and ! /[[:graph:]]/;
1484 report_multi_result($Locale, $locales_test_number, \@f);
1486 ++$locales_test_number;
1488 $test_names{$locales_test_number} = 'Verify that the space character is not in [:graph:]';
1489 if ($is_utf8_locale) {
1490 use locale ':not_characters';
1491 push @f, " " if " " =~ /[[:graph:]]/;
1494 push @f, " " if " " =~ /[[:graph:]]/;
1496 report_multi_result($Locale, $locales_test_number, \@f);
1498 ++$locales_test_number;
1500 $test_names{$locales_test_number} = 'Verify that [:space:] contains at least [\f\n\r\t\cK ]';
1501 for (' ', "\f", "\n", "\r", "\t", "\cK") {
1502 if ($is_utf8_locale) {
1503 use locale ':not_characters';
1504 push @f, $_ unless /[[:space:]]/;
1507 push @f, $_ unless /[[:space:]]/;
1510 report_multi_result($Locale, $locales_test_number, \@f);
1512 ++$locales_test_number;
1514 $test_names{$locales_test_number} = 'Verify that [:blank:] contains at least [\t ]';
1516 if ($is_utf8_locale) {
1517 use locale ':not_characters';
1518 push @f, $_ unless /[[:blank:]]/;
1521 push @f, $_ unless /[[:blank:]]/;
1524 report_multi_result($Locale, $locales_test_number, \@f);
1526 ++$locales_test_number;
1528 $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1529 for (map { chr } 0..255) {
1530 if ($is_utf8_locale) {
1531 use locale ':not_characters';
1532 push @f, $_ if /[[:blank:]]/ and ! /[[:space:]]/;
1535 push @f, $_ if /[[:blank:]]/ and ! /[[:space:]]/;
1538 report_multi_result($Locale, $locales_test_number, \@f);
1540 ++$locales_test_number;
1542 $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1543 for (map { chr } 0..255) {
1544 if ($is_utf8_locale) {
1545 use locale ':not_characters';
1546 push @f, $_ if /[[:graph:]]/ and ! /[[:print:]]/;
1549 push @f, $_ if /[[:graph:]]/ and ! /[[:print:]]/;
1552 report_multi_result($Locale, $locales_test_number, \@f);
1554 ++$locales_test_number;
1556 $test_names{$locales_test_number} = 'Verify that the space character is in [:print:]';
1557 if ($is_utf8_locale) {
1558 use locale ':not_characters';
1559 push @f, " " if " " !~ /[[:print:]]/;
1562 push @f, " " if " " !~ /[[:print:]]/;
1564 report_multi_result($Locale, $locales_test_number, \@f);
1566 ++$locales_test_number;
1568 $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1569 for (map { chr } 0..255) {
1570 if ($is_utf8_locale) {
1571 use locale ':not_characters';
1572 push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1575 push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1578 report_multi_result($Locale, $locales_test_number, \@f);
1580 ++$locales_test_number;
1582 $test_names{$locales_test_number} = 'Verify that isn\'t both [:alpha:] and [:digit:]';
1583 for (map { chr } 0..255) {
1584 if ($is_utf8_locale) {
1585 use locale ':not_characters';
1586 push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1589 push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1592 report_multi_result($Locale, $locales_test_number, \@f);
1594 ++$locales_test_number;
1596 $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1597 for (map { chr } 0..255) {
1598 if ($is_utf8_locale) {
1599 use locale ':not_characters';
1600 push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1603 push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1606 report_multi_result($Locale, $locales_test_number, \@f);
1608 ++$locales_test_number;
1610 $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1611 for (map { chr } 0..255) {
1612 if ($is_utf8_locale) {
1613 use locale ':not_characters';
1614 push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1617 push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1620 report_multi_result($Locale, $locales_test_number, \@f);
1622 ++$locales_test_number;
1624 $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1625 for (map { chr } 0..255) {
1626 if ($is_utf8_locale) {
1627 use locale ':not_characters';
1628 push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1631 push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1634 report_multi_result($Locale, $locales_test_number, \@f);
1636 foreach ($first_casing_test_number..$locales_test_number) {
1637 $problematical_tests{$_} = 1;
1641 # Test for read-only scalars' locale vs non-locale comparisons.
1647 if ($is_utf8_locale) {
1648 use locale ':not_characters';
1649 $ok = ($a cmp "qwerty") == 0;
1653 $ok = ($a cmp "qwerty") == 0;
1655 report_result($Locale, ++$locales_test_number, $ok);
1656 $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1660 my ($from, $to, $lesser, $greater,
1661 @test, %test, $test, $yes, $no, $sign);
1663 ++$locales_test_number;
1664 $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1665 $not_necessarily_a_problem_test_number = $locales_test_number;
1668 $from = int(($_*@{$posixes{'word'}})/10);
1669 $to = $from + int(@{$posixes{'word'}}/10);
1670 $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1671 $lesser = join('', @{$posixes{'word'}}[$from..$to]);
1672 # Select a slice one character on.
1674 $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1675 $greater = join('', @{$posixes{'word'}}[$from..$to]);
1676 if ($is_utf8_locale) {
1677 use locale ':not_characters';
1678 ($yes, $no, $sign) = ($lesser lt $greater
1680 : ("not ", " ", -1));
1684 ($yes, $no, $sign) = ($lesser lt $greater
1686 : ("not ", " ", -1));
1688 # all these tests should FAIL (return 0). Exact lt or gt cannot
1689 # be tested because in some locales, say, eacute and E may test
1693 $no.' ($lesser le $greater)', # 1
1694 'not ($lesser ne $greater)', # 2
1695 ' ($lesser eq $greater)', # 3
1696 $yes.' ($lesser ge $greater)', # 4
1697 $yes.' ($lesser ge $greater)', # 5
1698 $yes.' ($greater le $lesser )', # 7
1699 'not ($greater ne $lesser )', # 8
1700 ' ($greater eq $lesser )', # 9
1701 $no.' ($greater ge $lesser )', # 10
1702 'not (($lesser cmp $greater) == -($sign))' # 11
1704 @test{@test} = 0 x @test;
1706 for my $ti (@test) {
1707 if ($is_utf8_locale) {
1708 use locale ':not_characters';
1709 $test{$ti} = eval $ti;
1712 # Already in 'use locale';
1713 $test{$ti} = eval $ti;
1715 $test ||= $test{$ti}
1717 report_result($Locale, $locales_test_number, $test == 0);
1719 debug "lesser = '$lesser'\n";
1720 debug "greater = '$greater'\n";
1721 debug "lesser cmp greater = ",
1722 $lesser cmp $greater, "\n";
1723 debug "greater cmp lesser = ",
1724 $greater cmp $lesser, "\n";
1725 debug "(greater) from = $from, to = $to\n";
1726 for my $ti (@test) {
1727 debugf("# %-40s %-4s", $ti,
1728 $test{$ti} ? 'FAIL' : 'ok');
1729 if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1730 debugf("(%s == %4d)", $1, eval $1);
1772 if (! $is_utf8_locale) {
1775 my ($x, $y) = (1.23, 1.23);
1778 printf ''; # printf used to reset locale to "C"
1783 my $z = sprintf ''; # sprintf used to reset locale to "C"
1790 local $SIG{__WARN__} =
1796 # The == (among other ops) used to warn for locales
1797 # that had something else than "." as the radix character.
1821 $ok12 = abs(($f + $g) - 3.57) < 0.01;
1823 $ok14 = $ok14_5 = $ok15 = $ok16 = 1; # Skip for non-utf8 locales
1827 $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
1829 $ok18 = $j eq sprintf("%g:%g", $h, $i);
1832 use locale ':not_characters';
1834 my ($x, $y) = (1.23, 1.23);
1836 printf ''; # printf used to reset locale to "C"
1841 my $z = sprintf ''; # sprintf used to reset locale to "C"
1847 local $SIG{__WARN__} =
1873 $ok12 = abs(($f + $g) - 3.57) < 0.01;
1876 # Look for non-ASCII error messages, and verify that the first
1877 # such is in UTF-8 (the others almost certainly will be like the
1878 # first). This is only done if the current locale has LC_MESSAGES
1881 if ( locales_enabled('LC_MESSAGES')
1882 && setlocale(&POSIX::LC_MESSAGES, $Locale))
1884 foreach my $err (keys %!) {
1886 $! = eval "&Errno::$err"; # Convert to strerror() output
1887 my $strerror = "$!";
1888 if ("$strerror" =~ /\P{ASCII}/) {
1889 $ok14 = utf8::is_utf8($strerror);
1891 $ok14_5 = "$!" !~ /\P{ASCII}/;
1897 # Similarly, we verify that a non-ASCII radix is in UTF-8. This
1898 # also catches if there is a disparity between sprintf and
1901 my $string_g = "$g";
1902 my $sprintf_g = sprintf("%g", $g);
1904 $ok15 = $string_g =~ / ^ \p{ASCII}+ $ /x || utf8::is_utf8($string_g);
1905 $ok16 = $sprintf_g eq $string_g;
1909 $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
1911 $ok18 = $j eq sprintf("%g:%g", $h, $i);
1915 if (setlocale(&POSIX::LC_TIME, $Locale)) { # These tests aren't affected by
1917 my @times = CORE::localtime();
1920 $ok19 = POSIX::strftime("%p", @times) ne "%p"; # [perl #119425]
1921 my $date = POSIX::strftime("'%A' '%B' '%Z' '%p'", @times);
1922 debug("'Day' 'Month' 'TZ' 'am/pm' = ", disp_str($date));
1924 # If there is any non-ascii, it better be UTF-8 in a UTF-8 locale, and
1925 # not UTF-8 if the locale isn't UTF-8.
1926 $ok20 = $date =~ / ^ \p{ASCII}+ $ /x
1927 || $is_utf8_locale == utf8::is_utf8($date);
1931 if (locales_enabled('LC_MESSAGES')) {
1932 foreach my $err (keys %!) {
1935 $! = eval "&Errno::$err"; # Convert to strerror() output
1936 my $strerror = "$!";
1937 if ("$strerror" =~ /\P{ASCII}/) {
1944 report_result($Locale, ++$locales_test_number, $ok1);
1945 $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
1946 my $first_a_test = $locales_test_number;
1948 debug "$first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
1950 report_result($Locale, ++$locales_test_number, $ok2);
1951 $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
1953 my $first_c_test = $locales_test_number;
1955 $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
1956 if ($Config{usequadmath}) {
1957 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1958 report_result($Locale, $locales_test_number, 1);
1960 report_result($Locale, $locales_test_number, $ok3);
1961 $problematical_tests{$locales_test_number} = 1;
1964 $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
1965 if ($Config{usequadmath}) {
1966 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1967 report_result($Locale, $locales_test_number, 1);
1969 report_result($Locale, $locales_test_number, $ok4);
1970 $problematical_tests{$locales_test_number} = 1;
1973 report_result($Locale, ++$locales_test_number, $ok5);
1974 $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
1975 $problematical_tests{$locales_test_number} = 1;
1977 debug "$first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
1979 report_result($Locale, ++$locales_test_number, $ok6);
1980 $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
1981 my $first_e_test = $locales_test_number;
1983 report_result($Locale, ++$locales_test_number, $ok7);
1984 $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
1986 $test_names{++$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
1987 if ($Config{usequadmath}) {
1988 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1989 report_result($Locale, $locales_test_number, 1);
1991 report_result($Locale, $locales_test_number, $ok8);
1992 $problematical_tests{$locales_test_number} = 1;
1995 debug "$first_e_test..$locales_test_number: \$e = $e, no locale\n";
1997 report_result($Locale, ++$locales_test_number, $ok9);
1998 $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
1999 $problematical_tests{$locales_test_number} = 1;
2000 my $first_f_test = $locales_test_number;
2002 report_result($Locale, ++$locales_test_number, $ok10);
2003 $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
2004 $problematical_tests{$locales_test_number} = 1;
2006 $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';
2007 if ($Config{usequadmath}) {
2008 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
2009 report_result($Locale, $locales_test_number, 1);
2011 report_result($Locale, $locales_test_number, $ok11);
2012 $problematical_tests{$locales_test_number} = 1;
2015 report_result($Locale, ++$locales_test_number, $ok12);
2016 $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';
2017 $problematical_tests{$locales_test_number} = 1;
2019 report_result($Locale, ++$locales_test_number, $ok13);
2020 $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
2021 $problematical_tests{$locales_test_number} = 1;
2023 report_result($Locale, ++$locales_test_number, $ok14);
2024 $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
2026 report_result($Locale, ++$locales_test_number, $ok14_5);
2027 $test_names{$locales_test_number} = '... and are ASCII outside "use locale"';
2029 report_result($Locale, ++$locales_test_number, $ok15);
2030 $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
2032 report_result($Locale, ++$locales_test_number, $ok16);
2033 $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
2034 $problematical_tests{$locales_test_number} = 1;
2036 report_result($Locale, ++$locales_test_number, $ok17);
2037 $test_names{$locales_test_number} = 'Verify that a sprintf of a number outside locale scope uses a dot radix';
2039 report_result($Locale, ++$locales_test_number, $ok18);
2040 $test_names{$locales_test_number} = 'Verify that a sprintf of a number back within locale scope uses locale radix';
2041 $problematical_tests{$locales_test_number} = 1;
2043 report_result($Locale, ++$locales_test_number, $ok19);
2044 $test_names{$locales_test_number} = 'Verify that strftime doesn\'t return "%p" in locales where %p is empty';
2046 report_result($Locale, ++$locales_test_number, $ok20);
2047 $test_names{$locales_test_number} = 'Verify that strftime returns date with UTF-8 flag appropriately set';
2048 $problematical_tests{$locales_test_number} = 1; # This is broken in
2051 report_result($Locale, ++$locales_test_number, $ok21);
2052 $test_names{$locales_test_number} = '"$!" is ASCII only outside of locale scope';
2054 debug "$first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
2056 # Does taking lc separately differ from taking
2057 # the lc "in-line"? (This was the bug 19990704.002, change #3568.)
2058 # The bug was in the caching of the 'o'-magic.
2059 if (! $is_utf8_locale) {
2065 return $lc0 cmp $lc1;
2069 return lc($_[0]) cmp lc($_[1]);
2076 report_result($Locale, ++$locales_test_number,
2077 lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
2078 lcA($x, $z) == 0 && lcB($x, $z) == 0);
2081 use locale ':not_characters';
2086 return $lc0 cmp $lc1;
2090 return lc($_[0]) cmp lc($_[1]);
2097 report_result($Locale, ++$locales_test_number,
2098 lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
2099 lcC($x, $z) == 0 && lcD($x, $z) == 0);
2101 $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
2103 # Does lc of an UPPER (if different from the UPPER) match
2104 # case-insensitively the UPPER, and does the UPPER match
2105 # case-insensitively the lc of the UPPER. And vice versa.
2109 my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
2112 ++$locales_test_number;
2113 $test_names{$locales_test_number} = 'Verify case insensitive matching works';
2114 foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
2115 if (! $is_utf8_locale) {
2117 next unless uc $y eq $x;
2118 debug_more( "UPPER=", disp_chars(($x)),
2119 "; lc=", disp_chars(($y)), "; ",
2120 "; fc=", disp_chars((fc $x)), "; ",
2121 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2122 $x =~ /\Q$y/i ? 1 : 0,
2124 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2125 $y =~ /\Q$x/i ? 1 : 0,
2128 # If $x and $y contain regular expression characters
2129 # AND THEY lowercase (/i) to regular expression characters,
2130 # regcomp() will be mightily confused. No, the \Q doesn't
2131 # help here (maybe regex engine internal lowercasing
2132 # is done after the \Q?) An example of this happening is
2133 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
2134 # the chr(173) (the "[") is the lowercase of the chr(235).
2136 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
2137 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
2138 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
2139 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
2140 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
2141 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
2143 # Similar things can happen even under (bastardised)
2144 # non-EBCDIC locales: in many European countries before the
2145 # advent of ISO 8859-x nationally customised versions of
2146 # ISO 646 were devised, reusing certain punctuation
2147 # characters for modified characters needed by the
2148 # country/language. For example, the "|" might have
2149 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
2151 if ($x =~ $re || $y =~ $re) {
2152 print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2155 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2157 # fc is not a locale concept, so Perl uses lc for it.
2158 push @f, $x unless lc $x eq fc $x;
2161 use locale ':not_characters';
2163 next unless uc $y eq $x;
2164 debug_more( "UPPER=", disp_chars(($x)),
2165 "; lc=", disp_chars(($y)), "; ",
2166 "; fc=", disp_chars((fc $x)), "; ",
2167 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2168 $x =~ /\Q$y/i ? 1 : 0,
2170 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2171 $y =~ /\Q$x/i ? 1 : 0,
2174 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2176 # The places where Unicode's lc is different from fc are
2177 # skipped here by virtue of the 'next unless uc...' line above
2178 push @f, $x unless lc $x eq fc $x;
2182 foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
2183 if (! $is_utf8_locale) {
2185 next unless lc $y eq $x;
2186 debug_more( "lower=", disp_chars(($x)),
2187 "; uc=", disp_chars(($y)), "; ",
2188 "; fc=", disp_chars((fc $x)), "; ",
2189 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2190 $x =~ /\Q$y/i ? 1 : 0,
2192 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2193 $y =~ /\Q$x/i ? 1 : 0,
2195 if ($x =~ $re || $y =~ $re) { # See above.
2196 print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2199 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2201 push @f, $x unless lc $x eq fc $x;
2204 use locale ':not_characters';
2206 next unless lc $y eq $x;
2207 debug_more( "lower=", disp_chars(($x)),
2208 "; uc=", disp_chars(($y)), "; ",
2209 "; fc=", disp_chars((fc $x)), "; ",
2210 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2211 $x =~ /\Q$y/i ? 1 : 0,
2213 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2214 $y =~ /\Q$x/i ? 1 : 0,
2216 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2218 push @f, $x unless lc $x eq fc $x;
2221 report_multi_result($Locale, $locales_test_number, \@f);
2222 $problematical_tests{$locales_test_number} = 1;
2228 ++$locales_test_number;
2229 $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
2230 $problematical_tests{$locales_test_number} = 1;
2232 my $radix = POSIX::localeconv()->{decimal_point};
2234 "3.14e+9", "3${radix}14e+9", "3.14e-9", "3${radix}14e-9",
2235 "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
2238 if (! $is_utf8_locale) {
2240 for my $num (@nums) {
2242 unless sprintf("%g", $num) =~ /3.+14/;
2246 use locale ':not_characters';
2247 for my $num (@nums) {
2249 unless sprintf("%g", $num) =~ /3.+14/;
2253 if ($Config{usequadmath}) {
2254 print "# Skip: no locale radix with usequadmath ($Locale)\n";
2255 report_result($Locale, $locales_test_number, 1);
2257 report_result($Locale, $locales_test_number, @f == 0);
2259 print "# failed $locales_test_number locale '$Locale' numbers @f\n"
2265 my $final_locales_test_number = $locales_test_number;
2267 # Recount the errors.
2270 foreach $test_num ($first_locales_test_number..$final_locales_test_number) {
2271 if (%setlocale_failed) {
2274 elsif ($Problem{$test_num}
2275 || ! defined $Okay{$test_num}
2276 || ! @{$Okay{$test_num}})
2278 if (defined $not_necessarily_a_problem_test_number
2279 && $test_num == $not_necessarily_a_problem_test_number)
2281 print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
2282 print "# It usually indicates a problem in the environment,\n";
2283 print "# not in Perl itself.\n";
2286 # If there are any locales that pass this test, or are known-bad, it
2287 # may be that there are enough passes that we TODO the failure.
2288 if (($Okay{$test_num} || $Known_bad_locale{$test_num})
2289 && grep { $_ == $test_num } keys %problematical_tests)
2291 no warnings 'experimental::postderef';
2293 # Don't count the known-bad failures when calculating the
2294 # percentage that fail.
2295 my $known_failures = (exists $Known_bad_locale{$test_num})
2296 ? scalar(keys $Known_bad_locale{$test_num}->%*)
2298 my $adjusted_failures = scalar(keys $Problem{$test_num}->%*)
2301 # Specially handle failures where only known-bad locales fail.
2302 # This makes the diagnositics clearer.
2303 if ($adjusted_failures <= 0) {
2304 print "not ok $test_num $test_names{$test_num} # TODO fails only on ",
2305 "known bad locales: ",
2306 join " ", keys $Known_bad_locale{$test_num}->%*, "\n";
2310 # Round to nearest .1%
2311 my $percent_fail = (int(.5 + (1000 * $adjusted_failures
2312 / scalar(@Locale))))
2314 if ($percent_fail < $acceptable_failure_percentage) {
2316 $test_names{$test_num} .= 'TODO';
2317 print "# ", 100 - $percent_fail, "% of locales not known to be problematic on this platform\n";
2318 print "# pass the following test, so it is likely that the failures\n";
2319 print "# are errors in the locale definitions. The test is marked TODO, as the\n";
2320 print "# problem is not likely to be Perl's\n";
2324 print "# $percent_fail% of locales (",
2325 scalar(keys $Problem{$test_num}->%*),
2328 ") fail the above test (TODO cut-off is ",
2329 $acceptable_failure_percentage,
2335 print "# The code points that had this failure are given above. Look for lines\n";
2336 print "# that match 'failed $test_num'\n";
2339 print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2340 print "# Then look at that output for lines that match 'failed $test_num'\n";
2344 print "ok $test_num";
2345 if (defined $test_names{$test_num}) {
2346 # If TODO is in the test name, make it thus
2347 my $todo = $test_names{$test_num} =~ s/TODO\s*//;
2348 print " $test_names{$test_num}";
2349 print " # TODO" if $todo;
2354 $test_num = $final_locales_test_number;
2356 unless ( $^O =~ m!^(dragonfly|openbsd|bitrig|mirbsd)$! ) {
2360 local $SIG{__WARN__} = sub {
2361 $warned = $_[0] =~ /uninitialized/;
2363 my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
2364 ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
2367 # Test that tainting and case changing works on utf8 strings. These tests are
2368 # placed last to avoid disturbing the hard-coded test numbers that existed at
2369 # the time these were added above this in this file.
2370 # This also tests that locale overrides unicode_strings in the same scope for
2372 setlocale(&POSIX::LC_ALL, "C");
2375 use feature 'unicode_strings';
2377 foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
2378 my @list; # List of code points to test for $function
2380 # Used to calculate the changed case for ASCII characters by using the
2381 # ord, instead of using one of the functions under test.
2382 my $ascii_case_change_delta;
2383 my $above_latin1_case_change_delta; # Same for the specific ords > 255
2386 # We test an ASCII character, which should change case;
2387 # a Latin1 character, which shouldn't change case under this C locale,
2388 # an above-Latin1 character that when the case is changed would cross
2389 # the 255/256 boundary, so doesn't change case
2390 # (the \x{149} is one of these, but changes into 2 characters, the
2391 # first one of which doesn't cross the boundary.
2392 # the final one in each list is an above-Latin1 character whose case
2393 # does change. The code below uses its position in its list as a
2394 # marker to indicate that it, unlike the other code points above
2395 # ASCII, has a successful case change
2397 # All casing operations under locale (but not :not_characters) should
2399 if ($function =~ /^u/) {
2401 chr(utf8::unicode_to_native(0xe0)),
2402 chr(utf8::unicode_to_native(0xff)),
2403 "\x{fb00}", "\x{149}", "\x{101}");
2404 $ascii_case_change_delta = ($is_ebcdic) ? +64 : -32;
2405 $above_latin1_case_change_delta = -1;
2409 chr(utf8::unicode_to_native(0xC0)),
2410 "\x{17F}", "\x{100}");
2411 $ascii_case_change_delta = ($is_ebcdic) ? -64 : +32;
2412 $above_latin1_case_change_delta = +1;
2414 foreach my $is_utf8_locale (0 .. 1) {
2415 foreach my $j (0 .. $#list) {
2416 my $char = $list[$j];
2418 for my $encoded_in_utf8 (0 .. 1) {
2421 if (! $is_utf8_locale) {
2422 no warnings 'locale';
2423 $should_be = ($j == $#list)
2424 ? chr(ord($char) + $above_latin1_case_change_delta)
2425 : (length $char == 0 || utf8::native_to_unicode(ord($char)) > 127)
2427 : chr(ord($char) + $ascii_case_change_delta);
2429 # This monstrosity is in order to avoid using an eval,
2430 # which might perturb the results
2431 $changed = ($function eq "uc")
2433 : ($function eq "ucfirst")
2435 : ($function eq "lc")
2437 : ($function eq "lcfirst")
2439 : ($function eq "fc")
2441 : die("Unexpected function \"$function\"");
2447 # For utf8-locales the case changing functions
2448 # should work just like they do outside of locale.
2449 # Can use eval here because not testing it when
2451 $should_be = eval "$function('$char')";
2452 die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if $@;
2455 use locale ':not_characters';
2456 $changed = ($function eq "uc")
2458 : ($function eq "ucfirst")
2460 : ($function eq "lc")
2462 : ($function eq "lcfirst")
2464 : ($function eq "fc")
2466 : die("Unexpected function \"$function\"");
2468 ok($changed eq $should_be,
2469 "$function(\"$char\") in C locale "
2470 . (($is_utf8_locale)
2471 ? "(use locale ':not_characters'"
2473 . (($encoded_in_utf8)
2474 ? "; encoded in utf8)"
2475 : "; not encoded in utf8)")
2476 . " should be \"$should_be\", got \"$changed\"");
2478 # Tainting shouldn't happen for use locale :not_character
2481 ? check_taint($changed)
2482 : check_taint_not($changed);
2484 # Use UTF-8 next time through the loop
2485 utf8::upgrade($char);
2492 # Give final advice.
2496 foreach ($first_locales_test_number..$final_locales_test_number) {
2498 my @f = sort keys %{ $Problem{$_} };
2500 # Don't list the failures caused by known-bad locales.
2501 if (exists $known_bad_locales{$^O}) {
2502 @f = grep { $_ !~ $known_bad_locales{$^O} } @f;
2505 my $f = join(" ", @f);
2506 $f =~ s/(.{50,60}) /$1\n#\t/g;
2509 "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
2511 "# on your system may have errors because the locale test $_\n",
2512 "# \"$test_names{$_}\"\n",
2513 "# failed in ", (@f == 1 ? "that locale" : "those locales"),
2517 # If your users are not using these locales you are safe for the moment,
2518 # but please report this failure first to perlbug\@perl.com using the
2519 # perlbug script (as described in the INSTALL file) so that the exact
2520 # details of the failures can be sorted out first and then your operating
2521 # system supplier can be alerted about these anomalies.
2528 # Tell which locales were okay and which were not.
2533 foreach my $l (@Locale) {
2535 if ($setlocale_failed{$l}) {
2540 ($first_locales_test_number..$final_locales_test_number)
2542 $p++ if $Problem{$t}{$l};
2545 push @s, $l if $p == 0;
2546 push @F, $l unless $p == 0;
2550 my $s = join(" ", @s);
2551 $s =~ s/(.{50,60}) /$1\n#\t/g;
2554 "# The following locales\n#\n",
2556 "# tested okay.\n#\n",
2558 print "# None of your locales were fully okay.\n";
2562 my $F = join(" ", @F);
2563 $F =~ s/(.{50,60}) /$1\n#\t/g;
2567 $details = "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2569 elsif ($debug == 1) {
2570 $details = "# For even more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=2.\n";
2574 "# The following locales\n#\n",
2576 "# had problems.\n#\n",
2579 print "# None of your locales were broken.\n";
2583 if (exists $known_bad_locales{$^O} && ! %Known_bad_locale) {
2585 print "ok $test_num $^O no longer has known bad locales # TODO\n";
2588 print "1..$test_num\n";