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 binmode STDOUT, ':utf8';
11 binmode STDERR, ':utf8';
17 require Config; import Config;
18 if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
22 require './loc_tools.pl';
29 # =1 adds debugging output; =2 increases the verbosity somewhat
30 my $debug = $ENV{PERL_DEBUG_FULL_TEST} // 0;
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)
40 # The list of test numbers of the problematic tests.
41 my %problematical_tests;
43 # If any %problematical_tests fails in one of these locales, it is
45 my %known_bad_locales = (
46 irix => qr/ ^ (?: cs | hu | sk ) $/x,
47 darwin => qr/ ^ lt_LT.ISO8859 /ix,
48 os390 => qr/ ^ italian /ix,
53 my $dumper = Dumpvalue->new(
60 my($mess) = join "", '# ', @_;
62 print STDERR $dumper->stringify($mess,1), "\n";
66 return unless $debug > 1;
71 printf STDERR @_ if $debug;
79 my ($result, $message) = @_;
80 $message = "" unless defined $message;
82 print 'not ' unless ($result);
83 print "ok " . ++$test_num;
88 # First we'll do a lot of taint checking for locales.
89 # This is the easiest to test, actually, as any locale,
90 # even the default locale will taint under 'use locale'.
92 sub is_tainted { # hello, camel two.
93 no warnings 'uninitialized' ;
96 not eval { $dummy = join("", @_), kill 0; 1 }
99 sub check_taint ($;$) {
100 my $message_tail = $_[1] // "";
102 # Extra blanks are so aligns with taint_not output
103 $message_tail = ": $message_tail" if $message_tail;
104 ok is_tainted($_[0]), "verify that is tainted$message_tail";
107 sub check_taint_not ($;$) {
108 my $message_tail = $_[1] // "";
109 $message_tail = ": $message_tail" if $message_tail;
110 ok((not is_tainted($_[0])), "verify that isn't tainted$message_tail");
113 "\tb\t" =~ /^m?(\s)(.*)\1$/;
114 check_taint_not $&, "not tainted outside 'use locale'";
117 use locale; # engage locale and therefore locale taint.
119 # BE SURE TO COPY ANYTHING YOU ADD to these tests to the block below for
122 check_taint_not $a, '$a';
124 check_taint uc($a), 'uc($a)';
125 check_taint "\U$a", '"\U$a"';
126 check_taint ucfirst($a), 'ucfirst($a)';
127 check_taint "\u$a", '"\u$a"';
128 check_taint lc($a), 'lc($a)';
129 check_taint fc($a), 'fc($a)';
130 check_taint "\L$a", '"\L$a"';
131 check_taint "\F$a", '"\F$a"';
132 check_taint lcfirst($a), 'lcfirst($a)';
133 check_taint "\l$a", '"\l$a"';
135 check_taint_not sprintf('%e', 123.456), "sprintf('%e', 123.456)";
136 check_taint_not sprintf('%f', 123.456), "sprintf('%f', 123.456)";
137 check_taint_not sprintf('%g', 123.456), "sprintf('%g', 123.456)";
138 check_taint_not sprintf('%d', 123.456), "sprintf('%d', 123.456)";
139 check_taint_not sprintf('%x', 123.456), "sprintf('%x', 123.456)";
141 $_ = $a; # untaint $_
143 $_ = uc($a); # taint $_
145 check_taint $_, '$_ = uc($a)';
147 /(\w)/; # taint $&, $`, $', $+, $1.
148 check_taint $&, "\$& from /(\\w)/";
149 check_taint $`, "\t\$`";
150 check_taint $', "\t\$'";
151 check_taint $+, "\t\$+";
152 check_taint $1, "\t\$1";
153 check_taint_not $2, "\t\$2";
155 /(.)/; # untaint $&, $`, $', $+, $1.
156 check_taint_not $&, "\$& from /(.)/";
157 check_taint_not $`, "\t\$`";
158 check_taint_not $', "\t\$'";
159 check_taint_not $+, "\t\$+";
160 check_taint_not $1, "\t\$1";
161 check_taint_not $2, "\t\$2";
163 /(\W)/; # taint $&, $`, $', $+, $1.
164 check_taint $&, "\$& from /(\\W)/";
165 check_taint $`, "\t\$`";
166 check_taint $', "\t\$'";
167 check_taint $+, "\t\$+";
168 check_taint $1, "\t\$1";
169 check_taint_not $2, "\t\$2";
171 /(.)/; # untaint $&, $`, $', $+, $1.
172 check_taint_not $&, "\$& from /(.)/";
173 check_taint_not $`, "\t\$`";
174 check_taint_not $', "\t\$'";
175 check_taint_not $+, "\t\$+";
176 check_taint_not $1, "\t\$1";
177 check_taint_not $2, "\t\$2";
179 /(\s)/; # taint $&, $`, $', $+, $1.
180 check_taint $&, "\$& from /(\\s)/";
181 check_taint $`, "\t\$`";
182 check_taint $', "\t\$'";
183 check_taint $+, "\t\$+";
184 check_taint $1, "\t\$1";
185 check_taint_not $2, "\t\$2";
187 /(.)/; # untaint $&, $`, $', $+, $1.
188 check_taint_not $&, "\$& from /(.)/";
190 /(\S)/; # taint $&, $`, $', $+, $1.
191 check_taint $&, "\$& from /(\\S)/";
192 check_taint $`, "\t\$`";
193 check_taint $', "\t\$'";
194 check_taint $+, "\t\$+";
195 check_taint $1, "\t\$1";
196 check_taint_not $2, "\t\$2";
198 /(.)/; # untaint $&, $`, $', $+, $1.
199 check_taint_not $&, "\$& from /(.)/";
201 "0" =~ /(\d)/; # taint $&, $`, $', $+, $1.
202 check_taint $&, "\$& from /(\\d)/";
203 check_taint $`, "\t\$`";
204 check_taint $', "\t\$'";
205 check_taint $+, "\t\$+";
206 check_taint $1, "\t\$1";
207 check_taint_not $2, "\t\$2";
209 /(.)/; # untaint $&, $`, $', $+, $1.
210 check_taint_not $&, "\$& from /(.)/";
212 /(\D)/; # taint $&, $`, $', $+, $1.
213 check_taint $&, "\$& from /(\\D)/";
214 check_taint $`, "\t\$`";
215 check_taint $', "\t\$'";
216 check_taint $+, "\t\$+";
217 check_taint $1, "\t\$1";
218 check_taint_not $2, "\t\$2";
220 /(.)/; # untaint $&, $`, $', $+, $1.
221 check_taint_not $&, "\$& from /(.)/";
223 /([[:alnum:]])/; # taint $&, $`, $', $+, $1.
224 check_taint $&, "\$& from /([[:alnum:]])/";
225 check_taint $`, "\t\$`";
226 check_taint $', "\t\$'";
227 check_taint $+, "\t\$+";
228 check_taint $1, "\t\$1";
229 check_taint_not $2, "\t\$2";
231 /(.)/; # untaint $&, $`, $', $+, $1.
232 check_taint_not $&, "\$& from /(.)/";
234 /([[:^alnum:]])/; # taint $&, $`, $', $+, $1.
235 check_taint $&, "\$& from /([[:^alnum:]])/";
236 check_taint $`, "\t\$`";
237 check_taint $', "\t\$'";
238 check_taint $+, "\t\$+";
239 check_taint $1, "\t\$1";
240 check_taint_not $2, "\t\$2";
242 "a" =~ /(a)|(\w)/; # taint $&, $`, $', $+, $1.
243 check_taint $&, "\$& from /(a)|(\\w)/";
244 check_taint $`, "\t\$`";
245 check_taint $', "\t\$'";
246 check_taint $+, "\t\$+";
247 check_taint $1, "\t\$1";
248 ok($1 eq 'a', ("\t" x 5) . "\$1 is 'a'");
249 ok(! defined $2, ("\t" x 5) . "\$2 is undefined");
250 check_taint_not $2, "\t\$2";
251 check_taint_not $3, "\t\$3";
253 /(.)/; # untaint $&, $`, $', $+, $1.
254 check_taint_not $&, "\$& from /(.)/";
256 "\N{CYRILLIC SMALL LETTER A}" =~ /(\N{CYRILLIC CAPITAL LETTER A})/i; # no tainting because no locale dependence
257 check_taint_not $&, "\$& from /(\\N{CYRILLIC CAPITAL LETTER A})/i";
258 check_taint_not $`, "\t\$`";
259 check_taint_not $', "\t\$'";
260 check_taint_not $+, "\t\$+";
261 check_taint_not $1, "\t\$1";
262 ok($1 eq "\N{CYRILLIC SMALL LETTER A}", ("\t" x 4) . "\t\$1 is 'small cyrillic a'");
263 check_taint_not $2, "\t\$2";
265 /(.)/; # untaint $&, $`, $', $+, $1.
266 check_taint_not $&, "\$& from /./";
268 "(\N{KELVIN SIGN})" =~ /(\N{KELVIN SIGN})/i; # taints because depends on locale
269 check_taint $&, "\$& from /(\\N{KELVIN SIGN})/i";
270 check_taint $`, "\t\$`";
271 check_taint $', "\t\$'";
272 check_taint $+, "\t\$+";
273 check_taint $1, "\t\$1";
274 check_taint_not $2, "\t\$2";
276 /(.)/; # untaint $&, $`, $', $+, $1.
277 check_taint_not $&, "\$& from /(.)/";
279 "a:" =~ /(.)\b(.)/; # taint $&, $`, $', $+, $1.
280 check_taint $&, "\$& from /(.)\\b(.)/";
281 check_taint $`, "\t\$`";
282 check_taint $', "\t\$'";
283 check_taint $+, "\t\$+";
284 check_taint $1, "\t\$1";
285 check_taint $2, "\t\$2";
286 check_taint_not $3, "\t\$3";
288 /(.)/; # untaint $&, $`, $', $+, $1.
289 check_taint_not $&, "\$& from /./";
291 "aa" =~ /(.)\B(.)/; # taint $&, $`, $', $+, $1.
292 check_taint $&, "\$& from /(.)\\B(.)/";
293 check_taint $`, "\t\$`";
294 check_taint $', "\t\$'";
295 check_taint $+, "\t\$+";
296 check_taint $1, "\t\$1";
297 check_taint $2, "\t\$2";
298 check_taint_not $3, "\t\$3";
300 /(.)/; # untaint $&, $`, $', $+, $1.
301 check_taint_not $&, "\$& from /./";
303 "aaa" =~ /(.).(\1)/i; # notaint because not locale dependent
304 check_taint_not $&, "\$ & from /(.).(\\1)/";
305 check_taint_not $`, "\t\$`";
306 check_taint_not $', "\t\$'";
307 check_taint_not $+, "\t\$+";
308 check_taint_not $1, "\t\$1";
309 check_taint_not $2, "\t\$2";
310 check_taint_not $3, "\t\$3";
312 /(.)/; # untaint $&, $`, $', $+, $1.
313 check_taint_not $&, "\$ & from /./";
315 $_ = $a; # untaint $_
317 check_taint_not $_, 'untainting $_ works';
319 /(b)/; # this must not taint
320 check_taint_not $&, "\$ & from /(b)/";
321 check_taint_not $`, "\t\$`";
322 check_taint_not $', "\t\$'";
323 check_taint_not $+, "\t\$+";
324 check_taint_not $1, "\t\$1";
325 check_taint_not $2, "\t\$2";
327 $_ = $a; # untaint $_
329 check_taint_not $_, 'untainting $_ works';
331 $b = uc($a); # taint $b
332 s/(.+)/$b/; # this must taint only the $_
334 check_taint $_, '$_ (wasn\'t tainted) from s/(.+)/$b/ where $b is tainted';
335 check_taint_not $&, "\t\$&";
336 check_taint_not $`, "\t\$`";
337 check_taint_not $', "\t\$'";
338 check_taint_not $+, "\t\$+";
339 check_taint_not $1, "\t\$1";
340 check_taint_not $2, "\t\$2";
342 $_ = $a; # untaint $_
344 s/(.+)/b/; # this must not taint
345 check_taint_not $_, '$_ (wasn\'t tainted) from s/(.+)/b/';
346 check_taint_not $&, "\t\$&";
347 check_taint_not $`, "\t\$`";
348 check_taint_not $', "\t\$'";
349 check_taint_not $+, "\t\$+";
350 check_taint_not $1, "\t\$1";
351 check_taint_not $2, "\t\$2";
353 $b = $a; # untaint $b
355 ($b = $a) =~ s/\w/$&/;
356 check_taint $b, '$b from ($b = $a) =~ s/\w/$&/'; # $b should be tainted.
357 check_taint_not $a, '$a from ($b = $a) =~ s/\w/$&/'; # $a should be not.
359 $_ = $a; # untaint $_
361 s/(\w)/\l$1/; # this must taint
362 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\l$1/,'; # this must taint
363 check_taint $&, "\t\$&";
364 check_taint $`, "\t\$`";
365 check_taint $', "\t\$'";
366 check_taint $+, "\t\$+";
367 check_taint $1, "\t\$1";
368 check_taint_not $2, "\t\$2";
370 $_ = $a; # untaint $_
372 s/(\w)/\L$1/; # this must taint
373 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\L$1/,';
374 check_taint $&, "\t\$&";
375 check_taint $`, "\t\$`";
376 check_taint $', "\t\$'";
377 check_taint $+, "\t\$+";
378 check_taint $1, "\t\$1";
379 check_taint_not $2, "\t\$2";
381 $_ = $a; # untaint $_
383 s/(\w)/\u$1/; # this must taint
384 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\u$1/';
385 check_taint $&, "\t\$&";
386 check_taint $`, "\t\$`";
387 check_taint $', "\t\$'";
388 check_taint $+, "\t\$+";
389 check_taint $1, "\t\$1";
390 check_taint_not $2, "\t\$2";
392 $_ = $a; # untaint $_
394 s/(\w)/\U$1/; # this must taint
395 check_taint $_, '$_ (wasn\'t tainted) from s/(\w)/\U$1/';
396 check_taint $&, "\t\$&";
397 check_taint $`, "\t\$`";
398 check_taint $', "\t\$'";
399 check_taint $+, "\t\$+";
400 check_taint $1, "\t\$1";
401 check_taint_not $2, "\t\$2";
403 # After all this tainting $a should be cool.
405 check_taint_not $a, '$a still not tainted';
408 check_taint_not $1, '"a" =~ /([a-z])/';
409 "foo.bar_baz" =~ /^(.*)[._](.*?)$/; # Bug 120675
410 check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
412 # BE SURE TO COPY ANYTHING YOU ADD to the block below
414 { # This is just the previous tests copied here with a different
415 # compile-time pragma.
417 use locale ':not_characters'; # engage restricted locale with different
419 check_taint_not $a, '$a';
421 check_taint_not uc($a), 'uc($a)';
422 check_taint_not "\U$a", '"\U$a"';
423 check_taint_not ucfirst($a), 'ucfirst($a)';
424 check_taint_not "\u$a", '"\u$a"';
425 check_taint_not lc($a), 'lc($a)';
426 check_taint_not fc($a), 'fc($a)';
427 check_taint_not "\L$a", '"\L$a"';
428 check_taint_not "\F$a", '"\F$a"';
429 check_taint_not lcfirst($a), 'lcfirst($a)';
430 check_taint_not "\l$a", '"\l$a"';
432 check_taint_not sprintf('%e', 123.456), "sprintf('%e', 123.456)";
433 check_taint_not sprintf('%f', 123.456), "sprintf('%f', 123.456)";
434 check_taint_not sprintf('%g', 123.456), "sprintf('%g', 123.456)";
435 check_taint_not sprintf('%d', 123.456), "sprintf('%d', 123.456)";
436 check_taint_not sprintf('%x', 123.456), "sprintf('%x', 123.456)";
438 $_ = $a; # untaint $_
442 check_taint_not $_, '$_ = uc($a)';
445 check_taint_not $&, "\$& from /(\\w)/";
446 check_taint_not $`, "\t\$`";
447 check_taint_not $', "\t\$'";
448 check_taint_not $+, "\t\$+";
449 check_taint_not $1, "\t\$1";
450 check_taint_not $2, "\t\$2";
452 /(.)/; # untaint $&, $`, $', $+, $1.
453 check_taint_not $&, "\$& from /(.)/";
454 check_taint_not $`, "\t\$`";
455 check_taint_not $', "\t\$'";
456 check_taint_not $+, "\t\$+";
457 check_taint_not $1, "\t\$1";
458 check_taint_not $2, "\t\$2";
461 check_taint_not $&, "\$& from /(\\W)/";
462 check_taint_not $`, "\t\$`";
463 check_taint_not $', "\t\$'";
464 check_taint_not $+, "\t\$+";
465 check_taint_not $1, "\t\$1";
466 check_taint_not $2, "\t\$2";
468 /(.)/; # untaint $&, $`, $', $+, $1.
469 check_taint_not $&, "\$& from /(.)/";
470 check_taint_not $`, "\t\$`";
471 check_taint_not $', "\t\$'";
472 check_taint_not $+, "\t\$+";
473 check_taint_not $1, "\t\$1";
474 check_taint_not $2, "\t\$2";
477 check_taint_not $&, "\$& from /(\\s)/";
478 check_taint_not $`, "\t\$`";
479 check_taint_not $', "\t\$'";
480 check_taint_not $+, "\t\$+";
481 check_taint_not $1, "\t\$1";
482 check_taint_not $2, "\t\$2";
484 /(.)/; # untaint $&, $`, $', $+, $1.
485 check_taint_not $&, "\$& from /(.)/";
488 check_taint_not $&, "\$& from /(\\S)/";
489 check_taint_not $`, "\t\$`";
490 check_taint_not $', "\t\$'";
491 check_taint_not $+, "\t\$+";
492 check_taint_not $1, "\t\$1";
493 check_taint_not $2, "\t\$2";
495 /(.)/; # untaint $&, $`, $', $+, $1.
496 check_taint_not $&, "\$& from /(.)/";
499 check_taint_not $&, "\$& from /(\\d)/";
500 check_taint_not $`, "\t\$`";
501 check_taint_not $', "\t\$'";
502 check_taint_not $+, "\t\$+";
503 check_taint_not $1, "\t\$1";
504 check_taint_not $2, "\t\$2";
506 /(.)/; # untaint $&, $`, $', $+, $1.
507 check_taint_not $&, "\$& from /(.)/";
510 check_taint_not $&, "\$& from /(\\D)/";
511 check_taint_not $`, "\t\$`";
512 check_taint_not $', "\t\$'";
513 check_taint_not $+, "\t\$+";
514 check_taint_not $1, "\t\$1";
515 check_taint_not $2, "\t\$2";
517 /(.)/; # untaint $&, $`, $', $+, $1.
518 check_taint_not $&, "\$& from /(.)/";
521 check_taint_not $&, "\$& from /([[:alnum:]])/";
522 check_taint_not $`, "\t\$`";
523 check_taint_not $', "\t\$'";
524 check_taint_not $+, "\t\$+";
525 check_taint_not $1, "\t\$1";
526 check_taint_not $2, "\t\$2";
528 /(.)/; # untaint $&, $`, $', $+, $1.
529 check_taint_not $&, "\$& from /(.)/";
532 check_taint_not $&, "\$& from /([[:^alnum:]])/";
533 check_taint_not $`, "\t\$`";
534 check_taint_not $', "\t\$'";
535 check_taint_not $+, "\t\$+";
536 check_taint_not $1, "\t\$1";
537 check_taint_not $2, "\t\$2";
540 check_taint_not $&, "\$& from /(a)|(\\w)/";
541 check_taint_not $`, "\t\$`";
542 check_taint_not $', "\t\$'";
543 check_taint_not $+, "\t\$+";
544 check_taint_not $1, "\t\$1";
545 ok($1 eq 'a', ("\t" x 5) . "\$1 is 'a'");
546 ok(! defined $2, ("\t" x 5) . "\$2 is undefined");
547 check_taint_not $2, "\t\$2";
548 check_taint_not $3, "\t\$3";
550 /(.)/; # untaint $&, $`, $', $+, $1.
551 check_taint_not $&, "\$& from /(.)/";
553 "\N{CYRILLIC SMALL LETTER A}" =~ /(\N{CYRILLIC CAPITAL LETTER A})/i;
554 check_taint_not $&, "\$& from /(\\N{CYRILLIC CAPITAL LETTER A})/i";
555 check_taint_not $`, "\t\$`";
556 check_taint_not $', "\t\$'";
557 check_taint_not $+, "\t\$+";
558 check_taint_not $1, "\t\$1";
559 ok($1 eq "\N{CYRILLIC SMALL LETTER A}", ("\t" x 4) . "\t\$1 is 'small cyrillic a'");
560 check_taint_not $2, "\t\$2";
562 /(.)/; # untaint $&, $`, $', $+, $1.
563 check_taint_not $&, "\$& from /./";
565 "(\N{KELVIN SIGN})" =~ /(\N{KELVIN SIGN})/i;
566 check_taint_not $&, "\$& from /(\\N{KELVIN SIGN})/i";
567 check_taint_not $`, "\t\$`";
568 check_taint_not $', "\t\$'";
569 check_taint_not $+, "\t\$+";
570 check_taint_not $1, "\t\$1";
571 check_taint_not $2, "\t\$2";
573 /(.)/; # untaint $&, $`, $', $+, $1.
574 check_taint_not $&, "\$& from /(.)/";
577 check_taint_not $&, "\$& from /(.)\\b(.)/";
578 check_taint_not $`, "\t\$`";
579 check_taint_not $', "\t\$'";
580 check_taint_not $+, "\t\$+";
581 check_taint_not $1, "\t\$1";
582 check_taint_not $2, "\t\$2";
583 check_taint_not $3, "\t\$3";
585 /(.)/; # untaint $&, $`, $', $+, $1.
586 check_taint_not $&, "\$& from /./";
589 check_taint_not $&, "\$& from /(.)\\B(.)/";
590 check_taint_not $`, "\t\$`";
591 check_taint_not $', "\t\$'";
592 check_taint_not $+, "\t\$+";
593 check_taint_not $1, "\t\$1";
594 check_taint_not $2, "\t\$2";
595 check_taint_not $3, "\t\$3";
597 /(.)/; # untaint $&, $`, $', $+, $1.
598 check_taint_not $&, "\$& from /./";
600 "aaa" =~ /(.).(\1)/i; # notaint because not locale dependent
601 check_taint_not $&, "\$ & from /(.).(\\1)/";
602 check_taint_not $`, "\t\$`";
603 check_taint_not $', "\t\$'";
604 check_taint_not $+, "\t\$+";
605 check_taint_not $1, "\t\$1";
606 check_taint_not $2, "\t\$2";
607 check_taint_not $3, "\t\$3";
609 /(.)/; # untaint $&, $`, $', $+, $1.
610 check_taint_not $&, "\$ & from /./";
612 $_ = $a; # untaint $_
614 check_taint_not $_, 'untainting $_ works';
617 check_taint_not $&, "\$ & from /(b)/";
618 check_taint_not $`, "\t\$`";
619 check_taint_not $', "\t\$'";
620 check_taint_not $+, "\t\$+";
621 check_taint_not $1, "\t\$1";
622 check_taint_not $2, "\t\$2";
624 $_ = $a; # untaint $_
626 check_taint_not $_, 'untainting $_ works';
629 check_taint_not $_, '$_ (wasn\'t tainted) from s/(.+)/b/';
630 check_taint_not $&, "\t\$&";
631 check_taint_not $`, "\t\$`";
632 check_taint_not $', "\t\$'";
633 check_taint_not $+, "\t\$+";
634 check_taint_not $1, "\t\$1";
635 check_taint_not $2, "\t\$2";
637 $b = $a; # untaint $b
639 ($b = $a) =~ s/\w/$&/;
640 check_taint_not $b, '$b from ($b = $a) =~ s/\w/$&/';
641 check_taint_not $a, '$a from ($b = $a) =~ s/\w/$&/';
643 $_ = $a; # untaint $_
646 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\l$1/,'; # this must taint
647 check_taint_not $&, "\t\$&";
648 check_taint_not $`, "\t\$`";
649 check_taint_not $', "\t\$'";
650 check_taint_not $+, "\t\$+";
651 check_taint_not $1, "\t\$1";
652 check_taint_not $2, "\t\$2";
654 $_ = $a; # untaint $_
657 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\L$1/,';
658 check_taint_not $&, "\t\$&";
659 check_taint_not $`, "\t\$`";
660 check_taint_not $', "\t\$'";
661 check_taint_not $+, "\t\$+";
662 check_taint_not $1, "\t\$1";
663 check_taint_not $2, "\t\$2";
665 $_ = $a; # untaint $_
668 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\u$1/';
669 check_taint_not $&, "\t\$&";
670 check_taint_not $`, "\t\$`";
671 check_taint_not $', "\t\$'";
672 check_taint_not $+, "\t\$+";
673 check_taint_not $1, "\t\$1";
674 check_taint_not $2, "\t\$2";
676 $_ = $a; # untaint $_
679 check_taint_not $_, '$_ (wasn\'t tainted) from s/(\w)/\U$1/';
680 check_taint_not $&, "\t\$&";
681 check_taint_not $`, "\t\$`";
682 check_taint_not $', "\t\$'";
683 check_taint_not $+, "\t\$+";
684 check_taint_not $1, "\t\$1";
685 check_taint_not $2, "\t\$2";
687 # After all this tainting $a should be cool.
689 check_taint_not $a, '$a still not tainted';
692 check_taint_not $1, '"a" =~ /([a-z])/';
693 "foo.bar_baz" =~ /^(.*)[._](.*?)$/; # Bug 120675
694 check_taint_not $1, '"foo.bar_baz" =~ /^(.*)[._](.*?)$/';
698 # Here are in scope of 'use locale'
700 # I think we've seen quite enough of taint.
701 # Let us do some *real* locale work now,
702 # unless setlocale() is missing (i.e. minitest).
704 # The test number before our first setlocale()
705 my $final_without_setlocale = $test_num;
709 debug "Scanning for locales...\n";
711 require POSIX; import POSIX ':locale_h';
713 my @Locale = find_locales([ &POSIX::LC_CTYPE, &POSIX::LC_NUMERIC, &POSIX::LC_ALL ]);
721 print "1..$test_num\n";
726 setlocale(&POSIX::LC_ALL, "C");
732 my %Known_bad_locale; # Failed test for a locale known to be bad
734 my @Added_alpha; # Alphas that aren't in the C locale.
738 # This returns a display string denoting the input parameter @_, each
739 # entry of which is a single character in the range 0-255. The first part
740 # of the output is a string of the characters in @_ that are ASCII
741 # graphics, and hence unambiguously displayable. They are given by code
742 # point order. The second part is the remaining code points, the ordinals
743 # of which are each displayed as 2-digit hex. Blanks are inserted so as
744 # to keep anything from the first part looking like a 2-digit hex number.
747 my @chars = sort { ord $a <=> ord $b } @_;
751 push @chars, chr(258); # This sentinel simplifies the loop termination
753 foreach my $i (0 .. @chars - 1) {
754 my $char = $chars[$i];
758 # We avoid using [:posix:] classes, as these are being tested in this
759 # file. Each equivalence class below is for things that can appear in
760 # a range; those that can't be in a range have class -1. 0 for those
761 # which should be output in hex; and >0 for the other ranges
762 if ($char =~ /[A-Z]/) {
765 elsif ($char =~ /[a-z]/) {
768 elsif ($char =~ /[0-9]/) {
771 # Uncomment to get literal punctuation displayed instead of hex
772 #elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
773 # $class = -1; # Punct never appears in a range
776 $class = 0; # Output in hex
779 if (! defined $range_start) {
781 $output .= " " . $char;
784 $range_start = ord $char;
785 $start_class = $class;
787 } # A range ends if not consecutive, or the class-type changes
788 elsif (ord $char != ($range_end = ord($chars[$i-1])) + 1
789 || $class != $start_class)
792 # Here, the current character is not in the range. This means the
793 # previous character must have been. Output the range up through
795 my $range_length = $range_end - $range_start + 1;
796 if ($start_class > 0) {
797 $output .= " " . chr($range_start);
798 $output .= "-" . chr($range_end) if $range_length > 1;
801 $output .= sprintf(" %02X", $range_start);
802 $output .= sprintf("-%02X", $range_end) if $range_length > 1;
805 # Handle the new current character, as potentially beginning a new
819 # Displays the string unambiguously. ASCII printables are always output
820 # as-is, though perhaps separated by blanks from other characters. If
821 # entirely printable ASCII, just returns the string. Otherwise if valid
822 # UTF-8 it uses the character names for non-printable-ASCII. Otherwise it
823 # outputs hex for each non-ASCII-printable byte.
825 return $string if $string =~ / ^ [[:print:]]* $/xa;
828 my $prev_was_punct = 1; # Beginning is considered punct
829 if (utf8::valid($string) && utf8::is_utf8($string)) {
831 foreach my $char (split "", $string) {
833 # Keep punctuation adjacent to other characters; otherwise
834 # separate them with a blank
835 if ($char =~ /[[:punct:]]/a) {
839 elsif ($char =~ /[[:print:]]/a) {
840 $result .= " " unless $prev_was_punct;
845 $result .= " " unless $prev_was_punct;
846 $result .= charnames::viacode(ord $char);
853 foreach my $char (split "", $string) {
854 if ($char =~ /[[:punct:]]/a) {
858 elsif ($char =~ /[[:print:]]/a) {
859 $result .= " " unless $prev_was_punct;
864 $result .= " " unless $prev_was_punct;
865 $result .= sprintf("%02X", ord $char);
875 my ($Locale, $i, $pass_fail, $message) = @_;
877 $message = " ($message)" if $message;
879 push @{$Okay{$i}}, $Locale;
882 $Known_bad_locale{$i}{$Locale} = 1 if exists $known_bad_locales{$^O}
883 && $Locale =~ $known_bad_locales{$^O};
884 $Problem{$i}{$Locale} = 1;
885 debug "failed $i ($test_names{$i}) with locale '$Locale'$message\n";
889 sub report_multi_result {
890 my ($Locale, $i, $results_ref) = @_;
892 # $results_ref points to an array, each element of which is a character that was
893 # in error for this test numbered '$i'. If empty, the test passed
897 $message = join " ", "for", disp_chars(@$results_ref);
899 report_result($Locale, $i, @$results_ref == 0, $message);
902 my $first_locales_test_number = $final_without_setlocale + 1;
903 my $locales_test_number;
904 my $not_necessarily_a_problem_test_number;
905 my $first_casing_test_number;
906 my %setlocale_failed; # List of locales that setlocale() didn't work on
908 foreach my $Locale (@Locale) {
909 $locales_test_number = $first_locales_test_number - 1;
911 debug "Locale = $Locale\n";
913 unless (setlocale(&POSIX::LC_ALL, $Locale)) {
914 $setlocale_failed{$Locale} = $Locale;
918 # We test UTF-8 locales only under ':not_characters'; It is easier to
919 # test them in other test files than here. Non- UTF-8 locales are tested
920 # only under plain 'use locale', as otherwise we would have to convert
921 # everything in them to Unicode.
923 my %UPPER = (); # All alpha X for which uc(X) == X and lc(X) != X
924 my %lower = (); # All alpha X for which lc(X) == X and uc(X) != X
925 my %BoThCaSe = (); # All alpha X for which uc(X) == lc(X) == X
927 my $is_utf8_locale = is_locale_utf8($Locale);
929 debug "is utf8 locale? = $is_utf8_locale\n";
931 debug "radix = " . disp_str(localeconv()->{decimal_point}) . "\n";
933 if (! $is_utf8_locale) {
935 @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
936 @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
937 @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
938 @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
939 @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
940 @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
941 @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
942 @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
943 @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
944 @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
945 @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
946 @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
947 @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
948 @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
949 @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
951 # Sieve the uppercase and the lowercase.
953 for (@{$posixes{'word'}}) {
954 if (/[^\d_]/) { # skip digits and the _
965 use locale ':not_characters';
966 @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
967 @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
968 @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
969 @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
970 @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
971 @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
972 @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
973 @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
974 @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
975 @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
976 @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
977 @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
978 @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
979 @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
980 @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
981 for (@{$posixes{'word'}}) {
982 if (/[^\d_]/) { # skip digits and the _
993 # Ordered, where possible, in groups of "this is a subset of the next
995 debug ":upper: = ", disp_chars(@{$posixes{'upper'}}), "\n";
996 debug ":lower: = ", disp_chars(@{$posixes{'lower'}}), "\n";
997 debug ":cased: = ", disp_chars(@{$posixes{'cased'}}), "\n";
998 debug ":alpha: = ", disp_chars(@{$posixes{'alpha'}}), "\n";
999 debug ":alnum: = ", disp_chars(@{$posixes{'alnum'}}), "\n";
1000 debug " w = ", disp_chars(@{$posixes{'word'}}), "\n";
1001 debug ":graph: = ", disp_chars(@{$posixes{'graph'}}), "\n";
1002 debug ":print: = ", disp_chars(@{$posixes{'print'}}), "\n";
1003 debug " d = ", disp_chars(@{$posixes{'digit'}}), "\n";
1004 debug ":xdigit: = ", disp_chars(@{$posixes{'xdigit'}}), "\n";
1005 debug ":blank: = ", disp_chars(@{$posixes{'blank'}}), "\n";
1006 debug " s = ", disp_chars(@{$posixes{'space'}}), "\n";
1007 debug ":punct: = ", disp_chars(@{$posixes{'punct'}}), "\n";
1008 debug ":cntrl: = ", disp_chars(@{$posixes{'cntrl'}}), "\n";
1009 debug ":ascii: = ", disp_chars(@{$posixes{'ascii'}}), "\n";
1011 foreach (keys %UPPER) {
1013 $BoThCaSe{$_}++ if exists $lower{$_};
1015 foreach (keys %lower) {
1016 $BoThCaSe{$_}++ if exists $UPPER{$_};
1018 foreach (keys %BoThCaSe) {
1024 foreach my $ord ( 0 .. 255 ) {
1025 $Unassigned{chr $ord} = 1;
1027 foreach my $class (keys %posixes) {
1028 foreach my $char (@{$posixes{$class}}) {
1029 delete $Unassigned{$char};
1033 debug "UPPER = ", disp_chars(sort { ord $a <=> ord $b } keys %UPPER), "\n";
1034 debug "lower = ", disp_chars(sort { ord $a <=> ord $b } keys %lower), "\n";
1035 debug "BoThCaSe = ", disp_chars(sort { ord $a <=> ord $b } keys %BoThCaSe), "\n";
1036 debug "Unassigned = ", disp_chars(sort { ord $a <=> ord $b } keys %Unassigned), "\n";
1040 foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
1043 if ($is_utf8_locale) {
1044 use locale ':not_characters';
1045 $ok = $x =~ /[[:upper:]]/;
1046 $fold_ok = $x =~ /[[:lower:]]/i;
1050 $ok = $x =~ /[[:upper:]]/;
1051 $fold_ok = $x =~ /[[:lower:]]/i;
1053 push @failures, $x unless $ok;
1054 push @fold_failures, $x unless $fold_ok;
1056 $locales_test_number++;
1057 $first_casing_test_number = $locales_test_number;
1058 $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
1059 report_multi_result($Locale, $locales_test_number, \@failures);
1061 $locales_test_number++;
1063 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
1064 report_multi_result($Locale, $locales_test_number, \@fold_failures);
1067 undef @fold_failures;
1069 foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
1072 if ($is_utf8_locale) {
1073 use locale ':not_characters';
1074 $ok = $x =~ /[[:lower:]]/;
1075 $fold_ok = $x =~ /[[:upper:]]/i;
1079 $ok = $x =~ /[[:lower:]]/;
1080 $fold_ok = $x =~ /[[:upper:]]/i;
1082 push @failures, $x unless $ok;
1083 push @fold_failures, $x unless $fold_ok;
1086 $locales_test_number++;
1087 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
1088 report_multi_result($Locale, $locales_test_number, \@failures);
1090 $locales_test_number++;
1091 $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
1092 report_multi_result($Locale, $locales_test_number, \@fold_failures);
1094 { # Find the alphabetic characters that are not considered alphabetics
1095 # in the default (C) locale.
1100 for (keys %UPPER, keys %lower, keys %BoThCaSe) {
1101 push(@Added_alpha, $_) if (/\W/);
1105 @Added_alpha = sort { ord $a <=> ord $b } @Added_alpha;
1107 debug "Added_alpha = ", disp_chars(@Added_alpha), "\n";
1109 # Cross-check the whole 8-bit character set.
1111 ++$locales_test_number;
1113 $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
1114 for (map { chr } 0..255) {
1115 if ($is_utf8_locale) {
1116 use locale ':not_characters';
1117 push @f, $_ unless /[[:word:]]/ == /\w/;
1120 push @f, $_ unless /[[:word:]]/ == /\w/;
1123 report_multi_result($Locale, $locales_test_number, \@f);
1125 ++$locales_test_number;
1127 $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1128 for (map { chr } 0..255) {
1129 if ($is_utf8_locale) {
1130 use locale ':not_characters';
1131 push @f, $_ unless /[[:digit:]]/ == /\d/;
1134 push @f, $_ unless /[[:digit:]]/ == /\d/;
1137 report_multi_result($Locale, $locales_test_number, \@f);
1139 ++$locales_test_number;
1141 $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1142 for (map { chr } 0..255) {
1143 if ($is_utf8_locale) {
1144 use locale ':not_characters';
1145 push @f, $_ unless /[[:space:]]/ == /\s/;
1148 push @f, $_ unless /[[:space:]]/ == /\s/;
1151 report_multi_result($Locale, $locales_test_number, \@f);
1153 ++$locales_test_number;
1155 $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1156 for (map { chr } 0..255) {
1157 if ($is_utf8_locale) {
1158 use locale ':not_characters';
1159 push @f, $_ unless (/[[:alpha:]]/ xor /[[:^alpha:]]/) ||
1160 (/[[:alnum:]]/ xor /[[:^alnum:]]/) ||
1161 (/[[:ascii:]]/ xor /[[:^ascii:]]/) ||
1162 (/[[:blank:]]/ xor /[[:^blank:]]/) ||
1163 (/[[:cntrl:]]/ xor /[[:^cntrl:]]/) ||
1164 (/[[:digit:]]/ xor /[[:^digit:]]/) ||
1165 (/[[:graph:]]/ xor /[[:^graph:]]/) ||
1166 (/[[:lower:]]/ xor /[[:^lower:]]/) ||
1167 (/[[:print:]]/ xor /[[:^print:]]/) ||
1168 (/[[:space:]]/ xor /[[:^space:]]/) ||
1169 (/[[:upper:]]/ xor /[[:^upper:]]/) ||
1170 (/[[:word:]]/ xor /[[:^word:]]/) ||
1171 (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1173 # effectively is what [:cased:] would be if it existed.
1174 (/[[:upper:]]/i xor /[[:^upper:]]/i);
1177 push @f, $_ unless (/[[:alpha:]]/ xor /[[:^alpha:]]/) ||
1178 (/[[:alnum:]]/ xor /[[:^alnum:]]/) ||
1179 (/[[:ascii:]]/ xor /[[:^ascii:]]/) ||
1180 (/[[:blank:]]/ xor /[[:^blank:]]/) ||
1181 (/[[:cntrl:]]/ xor /[[:^cntrl:]]/) ||
1182 (/[[:digit:]]/ xor /[[:^digit:]]/) ||
1183 (/[[:graph:]]/ xor /[[:^graph:]]/) ||
1184 (/[[:lower:]]/ xor /[[:^lower:]]/) ||
1185 (/[[:print:]]/ xor /[[:^print:]]/) ||
1186 (/[[:space:]]/ xor /[[:^space:]]/) ||
1187 (/[[:upper:]]/ xor /[[:^upper:]]/) ||
1188 (/[[:word:]]/ xor /[[:^word:]]/) ||
1189 (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1190 (/[[:upper:]]/i xor /[[:^upper:]]/i);
1193 report_multi_result($Locale, $locales_test_number, \@f);
1195 # The rules for the relationships are given in:
1196 # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1199 ++$locales_test_number;
1201 $test_names{$locales_test_number} = 'Verify that [:lower:] contains at least a-z';
1203 if ($is_utf8_locale) {
1204 use locale ':not_characters';
1205 push @f, $_ unless /[[:lower:]]/;
1208 push @f, $_ unless /[[:lower:]]/;
1211 report_multi_result($Locale, $locales_test_number, \@f);
1213 ++$locales_test_number;
1215 $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1216 for (map { chr } 0..255) {
1217 if ($is_utf8_locale) {
1218 use locale ':not_characters';
1219 push @f, $_ if /[[:lower:]]/ and ! /[[:alpha:]]/;
1222 push @f, $_ if /[[:lower:]]/ and ! /[[:alpha:]]/;
1225 report_multi_result($Locale, $locales_test_number, \@f);
1227 ++$locales_test_number;
1229 $test_names{$locales_test_number} = 'Verify that [:upper:] contains at least A-Z';
1231 if ($is_utf8_locale) {
1232 use locale ':not_characters';
1233 push @f, $_ unless /[[:upper:]]/;
1236 push @f, $_ unless /[[:upper:]]/;
1239 report_multi_result($Locale, $locales_test_number, \@f);
1241 ++$locales_test_number;
1243 $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1244 for (map { chr } 0..255) {
1245 if ($is_utf8_locale) {
1246 use locale ':not_characters';
1247 push @f, $_ if /[[:upper:]]/ and ! /[[:alpha:]]/;
1250 push @f, $_ if /[[:upper:]]/ and ! /[[:alpha:]]/;
1253 report_multi_result($Locale, $locales_test_number, \@f);
1255 ++$locales_test_number;
1257 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1258 for (map { chr } 0..255) {
1259 if ($is_utf8_locale) {
1260 use locale ':not_characters';
1261 push @f, $_ if /[[:lower:]]/i and ! /[[:alpha:]]/;
1264 push @f, $_ if /[[:lower:]]/i and ! /[[:alpha:]]/;
1267 report_multi_result($Locale, $locales_test_number, \@f);
1269 ++$locales_test_number;
1271 $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1272 for (map { chr } 0..255) {
1273 if ($is_utf8_locale) {
1274 use locale ':not_characters';
1275 push @f, $_ if /[[:alpha:]]/ and ! /[[:alnum:]]/;
1278 push @f, $_ if /[[:alpha:]]/ and ! /[[:alnum:]]/;
1281 report_multi_result($Locale, $locales_test_number, \@f);
1283 ++$locales_test_number;
1285 $test_names{$locales_test_number} = 'Verify that [:digit:] contains at least 0-9';
1287 if ($is_utf8_locale) {
1288 use locale ':not_characters';
1289 push @f, $_ unless /[[:digit:]]/;
1292 push @f, $_ unless /[[:digit:]]/;
1295 report_multi_result($Locale, $locales_test_number, \@f);
1297 ++$locales_test_number;
1299 $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1300 for (map { chr } 0..255) {
1301 if ($is_utf8_locale) {
1302 use locale ':not_characters';
1303 push @f, $_ if /[[:digit:]]/ and ! /[[:alnum:]]/;
1306 push @f, $_ if /[[:digit:]]/ and ! /[[:alnum:]]/;
1309 report_multi_result($Locale, $locales_test_number, \@f);
1311 ++$locales_test_number;
1313 $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1314 report_result($Locale, $locales_test_number, @{$posixes{'digit'}} == 10 || @{$posixes{'digit'}} == 20);
1316 ++$locales_test_number;
1318 $test_names{$locales_test_number} = 'Verify that if there is a second set of digits in [:digit:], they are consecutive';
1319 if (@{$posixes{'digit'}} == 20) {
1321 for (map { chr } 0..255) {
1322 next unless /[[:digit:]]/;
1324 if (defined $previous_ord) {
1325 if ($is_utf8_locale) {
1326 use locale ':not_characters';
1327 push @f, $_ if ord $_ != $previous_ord + 1;
1330 push @f, $_ if ord $_ != $previous_ord + 1;
1333 $previous_ord = ord $_;
1336 report_multi_result($Locale, $locales_test_number, \@f);
1338 ++$locales_test_number;
1340 my @xdigit_digits; # :digit: & :xdigit:
1341 $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains one or two blocks of 10 consecutive [:digit:] chars';
1342 for (map { chr } 0..255) {
1343 if ($is_utf8_locale) {
1344 use locale ':not_characters';
1345 # For utf8 locales, we actually use a stricter test: that :digit:
1346 # is a subset of :xdigit:, as we know that only 0-9 should match
1347 push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
1350 push @xdigit_digits, $_ if /[[:digit:]]/ and /[[:xdigit:]]/;
1353 if (! $is_utf8_locale) {
1355 # For non-utf8 locales, @xdigit_digits is a list of the characters
1356 # that are both :xdigit: and :digit:. Because :digit: is stored in
1357 # increasing code point order (unless the tests above failed),
1358 # @xdigit_digits is as well. There should be exactly 10 or
1360 if (@xdigit_digits != 10 && @xdigit_digits != 20) {
1361 @f = @xdigit_digits;
1365 # Look for contiguity in the series, adding any wrong ones to @f
1366 my @temp = @xdigit_digits;
1368 push @f, $temp[1] if ($temp[0] != $temp[1] - 1)
1370 # Skip this test for the 0th character of
1371 # the second block of 10, as it won't be
1372 # contiguous with the previous block
1373 && (! defined $xdigit_digits[10]
1374 || $temp[1] != $xdigit_digits[10]);
1380 report_multi_result($Locale, $locales_test_number, \@f);
1382 ++$locales_test_number;
1384 $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains at least A-F, a-f';
1385 for ('A' .. 'F', 'a' .. 'f') {
1386 if ($is_utf8_locale) {
1387 use locale ':not_characters';
1388 push @f, $_ unless /[[:xdigit:]]/;
1391 push @f, $_ unless /[[:xdigit:]]/;
1394 report_multi_result($Locale, $locales_test_number, \@f);
1396 ++$locales_test_number;
1398 $test_names{$locales_test_number} = 'Verify that any additional members of [:xdigit:], are in groups of 6 consecutive code points';
1401 for my $chr (map { chr } 0..255) {
1402 next unless $chr =~ /[[:xdigit:]]/;
1403 if ($is_utf8_locale) {
1404 next if $chr =~ /[[:digit:]]/;
1407 next if grep { $chr eq $_ } @xdigit_digits;
1409 next if $chr =~ /[A-Fa-f]/;
1410 if (defined $previous_ord) {
1411 if ($is_utf8_locale) {
1412 use locale ':not_characters';
1413 push @f, $chr if ord $chr != $previous_ord + 1;
1416 push @f, $chr if ord $chr != $previous_ord + 1;
1421 undef $previous_ord;
1424 $previous_ord = ord $chr;
1427 report_multi_result($Locale, $locales_test_number, \@f);
1429 ++$locales_test_number;
1431 $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1432 for (map { chr } 0..255) {
1433 if ($is_utf8_locale) {
1434 use locale ':not_characters';
1435 push @f, $_ if /[[:xdigit:]]/ and ! /[[:graph:]]/;
1438 push @f, $_ if /[[:xdigit:]]/ and ! /[[:graph:]]/;
1441 report_multi_result($Locale, $locales_test_number, \@f);
1443 # Note that xdigit doesn't have to be a subset of alnum
1445 ++$locales_test_number;
1447 $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1448 for (map { chr } 0..255) {
1449 if ($is_utf8_locale) {
1450 use locale ':not_characters';
1451 push @f, $_ if /[[:punct:]]/ and ! /[[:graph:]]/;
1454 push @f, $_ if /[[:punct:]]/ and ! /[[:graph:]]/;
1457 report_multi_result($Locale, $locales_test_number, \@f);
1459 ++$locales_test_number;
1461 $test_names{$locales_test_number} = 'Verify that the space character is not in [:graph:]';
1462 if ($is_utf8_locale) {
1463 use locale ':not_characters';
1464 push @f, " " if " " =~ /[[:graph:]]/;
1467 push @f, " " if " " =~ /[[:graph:]]/;
1469 report_multi_result($Locale, $locales_test_number, \@f);
1471 ++$locales_test_number;
1473 $test_names{$locales_test_number} = 'Verify that [:space:] contains at least [\f\n\r\t\cK ]';
1474 for (' ', "\f", "\n", "\r", "\t", "\cK") {
1475 if ($is_utf8_locale) {
1476 use locale ':not_characters';
1477 push @f, $_ unless /[[:space:]]/;
1480 push @f, $_ unless /[[:space:]]/;
1483 report_multi_result($Locale, $locales_test_number, \@f);
1485 ++$locales_test_number;
1487 $test_names{$locales_test_number} = 'Verify that [:blank:] contains at least [\t ]';
1489 if ($is_utf8_locale) {
1490 use locale ':not_characters';
1491 push @f, $_ unless /[[:blank:]]/;
1494 push @f, $_ unless /[[:blank:]]/;
1497 report_multi_result($Locale, $locales_test_number, \@f);
1499 ++$locales_test_number;
1501 $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1502 for (map { chr } 0..255) {
1503 if ($is_utf8_locale) {
1504 use locale ':not_characters';
1505 push @f, $_ if /[[:blank:]]/ and ! /[[:space:]]/;
1508 push @f, $_ if /[[:blank:]]/ and ! /[[:space:]]/;
1511 report_multi_result($Locale, $locales_test_number, \@f);
1513 ++$locales_test_number;
1515 $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1516 for (map { chr } 0..255) {
1517 if ($is_utf8_locale) {
1518 use locale ':not_characters';
1519 push @f, $_ if /[[:graph:]]/ and ! /[[:print:]]/;
1522 push @f, $_ if /[[:graph:]]/ and ! /[[:print:]]/;
1525 report_multi_result($Locale, $locales_test_number, \@f);
1527 ++$locales_test_number;
1529 $test_names{$locales_test_number} = 'Verify that the space character is in [:print:]';
1530 if ($is_utf8_locale) {
1531 use locale ':not_characters';
1532 push @f, " " if " " !~ /[[:print:]]/;
1535 push @f, " " if " " !~ /[[:print:]]/;
1537 report_multi_result($Locale, $locales_test_number, \@f);
1539 ++$locales_test_number;
1541 $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1542 for (map { chr } 0..255) {
1543 if ($is_utf8_locale) {
1544 use locale ':not_characters';
1545 push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1548 push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1551 report_multi_result($Locale, $locales_test_number, \@f);
1553 ++$locales_test_number;
1555 $test_names{$locales_test_number} = 'Verify that isn\'t both [:alpha:] and [:digit:]';
1556 for (map { chr } 0..255) {
1557 if ($is_utf8_locale) {
1558 use locale ':not_characters';
1559 push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1562 push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1565 report_multi_result($Locale, $locales_test_number, \@f);
1567 ++$locales_test_number;
1569 $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1570 for (map { chr } 0..255) {
1571 if ($is_utf8_locale) {
1572 use locale ':not_characters';
1573 push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1576 push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1579 report_multi_result($Locale, $locales_test_number, \@f);
1581 ++$locales_test_number;
1583 $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1584 for (map { chr } 0..255) {
1585 if ($is_utf8_locale) {
1586 use locale ':not_characters';
1587 push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1590 push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1593 report_multi_result($Locale, $locales_test_number, \@f);
1595 ++$locales_test_number;
1597 $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1598 for (map { chr } 0..255) {
1599 if ($is_utf8_locale) {
1600 use locale ':not_characters';
1601 push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1604 push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1607 report_multi_result($Locale, $locales_test_number, \@f);
1609 foreach ($first_casing_test_number..$locales_test_number) {
1610 $problematical_tests{$_} = 1;
1614 # Test for read-only scalars' locale vs non-locale comparisons.
1620 if ($is_utf8_locale) {
1621 use locale ':not_characters';
1622 $ok = ($a cmp "qwerty") == 0;
1626 $ok = ($a cmp "qwerty") == 0;
1628 report_result($Locale, ++$locales_test_number, $ok);
1629 $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1633 my ($from, $to, $lesser, $greater,
1634 @test, %test, $test, $yes, $no, $sign);
1636 ++$locales_test_number;
1637 $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1638 $not_necessarily_a_problem_test_number = $locales_test_number;
1641 $from = int(($_*@{$posixes{'word'}})/10);
1642 $to = $from + int(@{$posixes{'word'}}/10);
1643 $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1644 $lesser = join('', @{$posixes{'word'}}[$from..$to]);
1645 # Select a slice one character on.
1647 $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1648 $greater = join('', @{$posixes{'word'}}[$from..$to]);
1649 if ($is_utf8_locale) {
1650 use locale ':not_characters';
1651 ($yes, $no, $sign) = ($lesser lt $greater
1653 : ("not ", " ", -1));
1657 ($yes, $no, $sign) = ($lesser lt $greater
1659 : ("not ", " ", -1));
1661 # all these tests should FAIL (return 0). Exact lt or gt cannot
1662 # be tested because in some locales, say, eacute and E may test
1666 $no.' ($lesser le $greater)', # 1
1667 'not ($lesser ne $greater)', # 2
1668 ' ($lesser eq $greater)', # 3
1669 $yes.' ($lesser ge $greater)', # 4
1670 $yes.' ($lesser ge $greater)', # 5
1671 $yes.' ($greater le $lesser )', # 7
1672 'not ($greater ne $lesser )', # 8
1673 ' ($greater eq $lesser )', # 9
1674 $no.' ($greater ge $lesser )', # 10
1675 'not (($lesser cmp $greater) == -($sign))' # 11
1677 @test{@test} = 0 x @test;
1679 for my $ti (@test) {
1680 if ($is_utf8_locale) {
1681 use locale ':not_characters';
1682 $test{$ti} = eval $ti;
1685 # Already in 'use locale';
1686 $test{$ti} = eval $ti;
1688 $test ||= $test{$ti}
1690 report_result($Locale, $locales_test_number, $test == 0);
1692 debug "lesser = '$lesser'\n";
1693 debug "greater = '$greater'\n";
1694 debug "lesser cmp greater = ",
1695 $lesser cmp $greater, "\n";
1696 debug "greater cmp lesser = ",
1697 $greater cmp $lesser, "\n";
1698 debug "(greater) from = $from, to = $to\n";
1699 for my $ti (@test) {
1700 debugf("# %-40s %-4s", $ti,
1701 $test{$ti} ? 'FAIL' : 'ok');
1702 if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1703 debugf("(%s == %4d)", $1, eval $1);
1745 if (! $is_utf8_locale) {
1748 my ($x, $y) = (1.23, 1.23);
1751 printf ''; # printf used to reset locale to "C"
1756 my $z = sprintf ''; # sprintf used to reset locale to "C"
1763 local $SIG{__WARN__} =
1769 # The == (among other ops) used to warn for locales
1770 # that had something else than "." as the radix character.
1794 $ok12 = abs(($f + $g) - 3.57) < 0.01;
1796 $ok14 = $ok14_5 = $ok15 = $ok16 = 1; # Skip for non-utf8 locales
1800 $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
1802 $ok18 = $j eq sprintf("%g:%g", $h, $i);
1805 use locale ':not_characters';
1807 my ($x, $y) = (1.23, 1.23);
1809 printf ''; # printf used to reset locale to "C"
1814 my $z = sprintf ''; # sprintf used to reset locale to "C"
1820 local $SIG{__WARN__} =
1846 $ok12 = abs(($f + $g) - 3.57) < 0.01;
1849 # Look for non-ASCII error messages, and verify that the first
1850 # such is in UTF-8 (the others almost certainly will be like the
1851 # first). This is only done if the current locale has LC_MESSAGES
1854 if (setlocale(&POSIX::LC_MESSAGES, $Locale)) {
1855 foreach my $err (keys %!) {
1857 $! = eval "&Errno::$err"; # Convert to strerror() output
1858 my $strerror = "$!";
1859 if ("$strerror" =~ /\P{ASCII}/) {
1860 $ok14 = utf8::is_utf8($strerror);
1862 $ok14_5 = "$!" !~ /\P{ASCII}/;
1868 # Similarly, we verify that a non-ASCII radix is in UTF-8. This
1869 # also catches if there is a disparity between sprintf and
1872 my $string_g = "$g";
1873 my $sprintf_g = sprintf("%g", $g);
1875 $ok15 = $string_g =~ / ^ \p{ASCII}+ $ /x || utf8::is_utf8($string_g);
1876 $ok16 = $sprintf_g eq $string_g;
1880 $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
1882 $ok18 = $j eq sprintf("%g:%g", $h, $i);
1886 if (setlocale(&POSIX::LC_TIME, $Locale)) { # These tests aren't affected by
1888 my @times = CORE::localtime();
1891 $ok19 = POSIX::strftime("%p", @times) ne "%p"; # [perl #119425]
1892 my $date = POSIX::strftime("'%A' '%B' '%Z' '%p'", @times);
1893 debug("'Day' 'Month' 'TZ' 'am/pm' = ", disp_str($date));
1895 # If there is any non-ascii, it better be UTF-8 in a UTF-8 locale, and
1896 # not UTF-8 if the locale isn't UTF-8.
1897 $ok20 = $date =~ / ^ \p{ASCII}+ $ /x
1898 || $is_utf8_locale == utf8::is_utf8($date);
1902 foreach my $err (keys %!) {
1905 $! = eval "&Errno::$err"; # Convert to strerror() output
1906 my $strerror = "$!";
1907 if ("$strerror" =~ /\P{ASCII}/) {
1913 report_result($Locale, ++$locales_test_number, $ok1);
1914 $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
1915 my $first_a_test = $locales_test_number;
1917 debug "$first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
1919 report_result($Locale, ++$locales_test_number, $ok2);
1920 $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
1922 my $first_c_test = $locales_test_number;
1924 $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
1925 if ($Config{usequadmath}) {
1926 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1927 report_result($Locale, $locales_test_number, 1);
1929 report_result($Locale, $locales_test_number, $ok3);
1930 $problematical_tests{$locales_test_number} = 1;
1933 $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
1934 if ($Config{usequadmath}) {
1935 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1936 report_result($Locale, $locales_test_number, 1);
1938 report_result($Locale, $locales_test_number, $ok4);
1939 $problematical_tests{$locales_test_number} = 1;
1942 report_result($Locale, ++$locales_test_number, $ok5);
1943 $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
1944 $problematical_tests{$locales_test_number} = 1;
1946 debug "$first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
1948 report_result($Locale, ++$locales_test_number, $ok6);
1949 $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
1950 my $first_e_test = $locales_test_number;
1952 report_result($Locale, ++$locales_test_number, $ok7);
1953 $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
1955 $test_names{++$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
1956 if ($Config{usequadmath}) {
1957 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1958 report_result($Locale, $locales_test_number, 1);
1960 report_result($Locale, $locales_test_number, $ok8);
1961 $problematical_tests{$locales_test_number} = 1;
1964 debug "$first_e_test..$locales_test_number: \$e = $e, no locale\n";
1966 report_result($Locale, ++$locales_test_number, $ok9);
1967 $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
1968 $problematical_tests{$locales_test_number} = 1;
1969 my $first_f_test = $locales_test_number;
1971 report_result($Locale, ++$locales_test_number, $ok10);
1972 $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
1973 $problematical_tests{$locales_test_number} = 1;
1975 $test_names{++$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar and an intervening sprintf';
1976 if ($Config{usequadmath}) {
1977 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1978 report_result($Locale, $locales_test_number, 1);
1980 report_result($Locale, $locales_test_number, $ok11);
1981 $problematical_tests{$locales_test_number} = 1;
1984 report_result($Locale, ++$locales_test_number, $ok12);
1985 $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix can participate in an addition and function call as numeric';
1986 $problematical_tests{$locales_test_number} = 1;
1988 report_result($Locale, ++$locales_test_number, $ok13);
1989 $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
1990 $problematical_tests{$locales_test_number} = 1;
1992 report_result($Locale, ++$locales_test_number, $ok14);
1993 $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
1995 report_result($Locale, ++$locales_test_number, $ok14_5);
1996 $test_names{$locales_test_number} = '... and are ASCII outside "use locale"';
1998 report_result($Locale, ++$locales_test_number, $ok15);
1999 $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
2001 report_result($Locale, ++$locales_test_number, $ok16);
2002 $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
2004 report_result($Locale, ++$locales_test_number, $ok17);
2005 $test_names{$locales_test_number} = 'Verify that a sprintf of a number outside locale scope uses a dot radix';
2007 report_result($Locale, ++$locales_test_number, $ok18);
2008 $test_names{$locales_test_number} = 'Verify that a sprintf of a number back within locale scope uses locale radix';
2010 report_result($Locale, ++$locales_test_number, $ok19);
2011 $test_names{$locales_test_number} = 'Verify that strftime doesn\'t return "%p" in locales where %p is empty';
2013 report_result($Locale, ++$locales_test_number, $ok20);
2014 $test_names{$locales_test_number} = 'Verify that strftime returns date with UTF-8 flag appropriately set';
2015 $problematical_tests{$locales_test_number} = 1; # This is broken in
2018 report_result($Locale, ++$locales_test_number, $ok21);
2019 $test_names{$locales_test_number} = '"$!" is ASCII only outside of locale scope';
2021 debug "$first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
2023 # Does taking lc separately differ from taking
2024 # the lc "in-line"? (This was the bug 19990704.002, change #3568.)
2025 # The bug was in the caching of the 'o'-magic.
2026 if (! $is_utf8_locale) {
2032 return $lc0 cmp $lc1;
2036 return lc($_[0]) cmp lc($_[1]);
2043 report_result($Locale, ++$locales_test_number,
2044 lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
2045 lcA($x, $z) == 0 && lcB($x, $z) == 0);
2048 use locale ':not_characters';
2053 return $lc0 cmp $lc1;
2057 return lc($_[0]) cmp lc($_[1]);
2064 report_result($Locale, ++$locales_test_number,
2065 lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
2066 lcC($x, $z) == 0 && lcD($x, $z) == 0);
2068 $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
2070 # Does lc of an UPPER (if different from the UPPER) match
2071 # case-insensitively the UPPER, and does the UPPER match
2072 # case-insensitively the lc of the UPPER. And vice versa.
2076 my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
2079 ++$locales_test_number;
2080 $test_names{$locales_test_number} = 'Verify case insensitive matching works';
2081 foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
2082 if (! $is_utf8_locale) {
2084 next unless uc $y eq $x;
2085 debug_more( "UPPER=", disp_chars(($x)),
2086 "; lc=", disp_chars(($y)), "; ",
2087 "; fc=", disp_chars((fc $x)), "; ",
2088 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2089 $x =~ /\Q$y/i ? 1 : 0,
2091 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2092 $y =~ /\Q$x/i ? 1 : 0,
2095 # If $x and $y contain regular expression characters
2096 # AND THEY lowercase (/i) to regular expression characters,
2097 # regcomp() will be mightily confused. No, the \Q doesn't
2098 # help here (maybe regex engine internal lowercasing
2099 # is done after the \Q?) An example of this happening is
2100 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
2101 # the chr(173) (the "[") is the lowercase of the chr(235).
2103 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
2104 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
2105 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
2106 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
2107 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
2108 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
2110 # Similar things can happen even under (bastardised)
2111 # non-EBCDIC locales: in many European countries before the
2112 # advent of ISO 8859-x nationally customised versions of
2113 # ISO 646 were devised, reusing certain punctuation
2114 # characters for modified characters needed by the
2115 # country/language. For example, the "|" might have
2116 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
2118 if ($x =~ $re || $y =~ $re) {
2119 print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2122 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2124 # fc is not a locale concept, so Perl uses lc for it.
2125 push @f, $x unless lc $x eq fc $x;
2128 use locale ':not_characters';
2130 next unless uc $y eq $x;
2131 debug_more( "UPPER=", disp_chars(($x)),
2132 "; lc=", disp_chars(($y)), "; ",
2133 "; fc=", disp_chars((fc $x)), "; ",
2134 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2135 $x =~ /\Q$y/i ? 1 : 0,
2137 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2138 $y =~ /\Q$x/i ? 1 : 0,
2141 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2143 # The places where Unicode's lc is different from fc are
2144 # skipped here by virtue of the 'next unless uc...' line above
2145 push @f, $x unless lc $x eq fc $x;
2149 foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
2150 if (! $is_utf8_locale) {
2152 next unless lc $y eq $x;
2153 debug_more( "lower=", disp_chars(($x)),
2154 "; uc=", disp_chars(($y)), "; ",
2155 "; fc=", disp_chars((fc $x)), "; ",
2156 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2157 $x =~ /\Q$y/i ? 1 : 0,
2159 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2160 $y =~ /\Q$x/i ? 1 : 0,
2162 if ($x =~ $re || $y =~ $re) { # See above.
2163 print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2166 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2168 push @f, $x unless lc $x eq fc $x;
2171 use locale ':not_characters';
2173 next unless lc $y eq $x;
2174 debug_more( "lower=", disp_chars(($x)),
2175 "; uc=", disp_chars(($y)), "; ",
2176 "; fc=", disp_chars((fc $x)), "; ",
2177 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2178 $x =~ /\Q$y/i ? 1 : 0,
2180 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2181 $y =~ /\Q$x/i ? 1 : 0,
2183 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2185 push @f, $x unless lc $x eq fc $x;
2188 report_multi_result($Locale, $locales_test_number, \@f);
2189 $problematical_tests{$locales_test_number} = 1;
2195 ++$locales_test_number;
2196 $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
2197 $problematical_tests{$locales_test_number} = 1;
2199 my $radix = POSIX::localeconv()->{decimal_point};
2201 "3.14e+9", "3${radix}14e+9", "3.14e-9", "3${radix}14e-9",
2202 "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
2205 if (! $is_utf8_locale) {
2207 for my $num (@nums) {
2209 unless sprintf("%g", $num) =~ /3.+14/;
2213 use locale ':not_characters';
2214 for my $num (@nums) {
2216 unless sprintf("%g", $num) =~ /3.+14/;
2220 if ($Config{usequadmath}) {
2221 print "# Skip: no locale radix with usequadmath ($Locale)\n";
2222 report_result($Locale, $locales_test_number, 1);
2224 report_result($Locale, $locales_test_number, @f == 0);
2226 print "# failed $locales_test_number locale '$Locale' numbers @f\n"
2232 my $final_locales_test_number = $locales_test_number;
2234 # Recount the errors.
2237 foreach $test_num ($first_locales_test_number..$final_locales_test_number) {
2238 if (%setlocale_failed) {
2241 elsif ($Problem{$test_num}
2242 || ! defined $Okay{$test_num}
2243 || ! @{$Okay{$test_num}})
2245 if (defined $not_necessarily_a_problem_test_number
2246 && $test_num == $not_necessarily_a_problem_test_number)
2248 print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
2249 print "# It usually indicates a problem in the environment,\n";
2250 print "# not in Perl itself.\n";
2253 # If there are any locales that pass this test, or are known-bad, it
2254 # may be that there are enough passes that we TODO the failure.
2255 if (($Okay{$test_num} || $Known_bad_locale{$test_num})
2256 && grep { $_ == $test_num } keys %problematical_tests)
2258 no warnings 'experimental::autoderef';
2260 # Don't count the known-bad failures when calculating the
2261 # percentage that fail.
2262 my $known_failures = (exists $Known_bad_locale{$test_num})
2263 ? scalar(keys $Known_bad_locale{$test_num})
2265 my $adjusted_failures = scalar(keys $Problem{$test_num})
2268 # Specially handle failures where only known-bad locales fail.
2269 # This makes the diagnositics clearer.
2270 if ($adjusted_failures <= 0) {
2271 print "not ok $test_num $test_names{$test_num} # TODO fails only on ",
2272 "known bad locales: ",
2273 join " ", keys $Known_bad_locale{$test_num}, "\n";
2277 # Round to nearest .1%
2278 my $percent_fail = (int(.5 + (1000 * $adjusted_failures
2279 / scalar(@Locale))))
2281 if ($percent_fail < $acceptable_failure_percentage) {
2283 $test_names{$test_num} .= 'TODO';
2284 print "# ", 100 - $percent_fail, "% of locales not known to be problematic on this platform\n";
2285 print "# pass the following test, so it is likely that the failures\n";
2286 print "# are errors in the locale definitions. The test is marked TODO, as the\n";
2287 print "# problem is not likely to be Perl's\n";
2291 print "# $percent_fail% of locales (",
2292 scalar(keys $Problem{$test_num}),
2295 ") fail the above test (TODO cut-off is ",
2296 $acceptable_failure_percentage,
2302 print "# The code points that had this failure are given above. Look for lines\n";
2303 print "# that match 'failed $test_num'\n";
2306 print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2307 print "# Then look at that output for lines that match 'failed $test_num'\n";
2311 print "ok $test_num";
2312 if (defined $test_names{$test_num}) {
2313 # If TODO is in the test name, make it thus
2314 my $todo = $test_names{$test_num} =~ s/TODO\s*//;
2315 print " $test_names{$test_num}";
2316 print " # TODO" if $todo;
2321 $test_num = $final_locales_test_number;
2323 unless ( $^O =~ m!^(dragonfly|openbsd|bitrig|mirbsd)$! ) {
2327 local $SIG{__WARN__} = sub {
2328 $warned = $_[0] =~ /uninitialized/;
2330 my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
2331 ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
2334 # Test that tainting and case changing works on utf8 strings. These tests are
2335 # placed last to avoid disturbing the hard-coded test numbers that existed at
2336 # the time these were added above this in this file.
2337 # This also tests that locale overrides unicode_strings in the same scope for
2339 setlocale(&POSIX::LC_ALL, "C");
2342 use feature 'unicode_strings';
2344 foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
2345 my @list; # List of code points to test for $function
2347 # Used to calculate the changed case for ASCII characters by using the
2348 # ord, instead of using one of the functions under test.
2349 my $ascii_case_change_delta;
2350 my $above_latin1_case_change_delta; # Same for the specific ords > 255
2353 # We test an ASCII character, which should change case;
2354 # a Latin1 character, which shouldn't change case under this C locale,
2355 # an above-Latin1 character that when the case is changed would cross
2356 # the 255/256 boundary, so doesn't change case
2357 # (the \x{149} is one of these, but changes into 2 characters, the
2358 # first one of which doesn't cross the boundary.
2359 # the final one in each list is an above-Latin1 character whose case
2360 # does change. The code below uses its position in its list as a
2361 # marker to indicate that it, unlike the other code points above
2362 # ASCII, has a successful case change
2364 # All casing operations under locale (but not :not_characters) should
2366 if ($function =~ /^u/) {
2367 @list = ("", "a", "\xe0", "\xff", "\x{fb00}", "\x{149}", "\x{101}");
2368 $ascii_case_change_delta = -32;
2369 $above_latin1_case_change_delta = -1;
2372 @list = ("", "A", "\xC0", "\x{17F}", "\x{100}");
2373 $ascii_case_change_delta = +32;
2374 $above_latin1_case_change_delta = +1;
2376 foreach my $is_utf8_locale (0 .. 1) {
2377 foreach my $j (0 .. $#list) {
2378 my $char = $list[$j];
2380 for my $encoded_in_utf8 (0 .. 1) {
2383 if (! $is_utf8_locale) {
2384 no warnings 'locale';
2385 $should_be = ($j == $#list)
2386 ? chr(ord($char) + $above_latin1_case_change_delta)
2387 : (length $char == 0 || ord($char) > 127)
2389 : chr(ord($char) + $ascii_case_change_delta);
2391 # This monstrosity is in order to avoid using an eval,
2392 # which might perturb the results
2393 $changed = ($function eq "uc")
2395 : ($function eq "ucfirst")
2397 : ($function eq "lc")
2399 : ($function eq "lcfirst")
2401 : ($function eq "fc")
2403 : die("Unexpected function \"$function\"");
2409 # For utf8-locales the case changing functions
2410 # should work just like they do outside of locale.
2411 # Can use eval here because not testing it when
2413 $should_be = eval "$function('$char')";
2414 die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if $@;
2417 use locale ':not_characters';
2418 $changed = ($function eq "uc")
2420 : ($function eq "ucfirst")
2422 : ($function eq "lc")
2424 : ($function eq "lcfirst")
2426 : ($function eq "fc")
2428 : die("Unexpected function \"$function\"");
2430 ok($changed eq $should_be,
2431 "$function(\"$char\") in C locale "
2432 . (($is_utf8_locale)
2433 ? "(use locale ':not_characters'"
2435 . (($encoded_in_utf8)
2436 ? "; encoded in utf8)"
2437 : "; not encoded in utf8)")
2438 . " should be \"$should_be\", got \"$changed\"");
2440 # Tainting shouldn't happen for use locale :not_character
2443 ? check_taint($changed)
2444 : check_taint_not($changed);
2446 # Use UTF-8 next time through the loop
2447 utf8::upgrade($char);
2454 # Give final advice.
2458 foreach ($first_locales_test_number..$final_locales_test_number) {
2460 my @f = sort keys %{ $Problem{$_} };
2462 # Don't list the failures caused by known-bad locales.
2463 if (exists $known_bad_locales{$^O}) {
2464 @f = grep { $_ !~ $known_bad_locales{$^O} } @f;
2467 my $f = join(" ", @f);
2468 $f =~ s/(.{50,60}) /$1\n#\t/g;
2471 "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
2473 "# on your system may have errors because the locale test $_\n",
2474 "# \"$test_names{$_}\"\n",
2475 "# failed in ", (@f == 1 ? "that locale" : "those locales"),
2479 # If your users are not using these locales you are safe for the moment,
2480 # but please report this failure first to perlbug\@perl.com using the
2481 # perlbug script (as described in the INSTALL file) so that the exact
2482 # details of the failures can be sorted out first and then your operating
2483 # system supplier can be alerted about these anomalies.
2490 # Tell which locales were okay and which were not.
2495 foreach my $l (@Locale) {
2497 if ($setlocale_failed{$l}) {
2502 ($first_locales_test_number..$final_locales_test_number)
2504 $p++ if $Problem{$t}{$l};
2507 push @s, $l if $p == 0;
2508 push @F, $l unless $p == 0;
2512 my $s = join(" ", @s);
2513 $s =~ s/(.{50,60}) /$1\n#\t/g;
2516 "# The following locales\n#\n",
2518 "# tested okay.\n#\n",
2520 print "# None of your locales were fully okay.\n";
2524 my $F = join(" ", @F);
2525 $F =~ s/(.{50,60}) /$1\n#\t/g;
2529 $details = "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2531 elsif ($debug == 1) {
2532 $details = "# For even more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=2.\n";
2536 "# The following locales\n#\n",
2538 "# had problems.\n#\n",
2541 print "# None of your locales were broken.\n";
2545 if (exists $known_bad_locales{$^O} && ! %Known_bad_locale) {
2547 print "ok $test_num $^O no longer has known bad locales # TODO\n";
2550 print "1..$test_num\n";