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 no warnings 'locale'; # We test even weird locales;
715 my @Locale = find_locales([ &POSIX::LC_CTYPE, &POSIX::LC_NUMERIC, &POSIX::LC_ALL ]);
723 print "1..$test_num\n";
728 setlocale(&POSIX::LC_ALL, "C");
734 my %Known_bad_locale; # Failed test for a locale known to be bad
736 my @Added_alpha; # Alphas that aren't in the C locale.
740 # This returns a display string denoting the input parameter @_, each
741 # entry of which is a single character in the range 0-255. The first part
742 # of the output is a string of the characters in @_ that are ASCII
743 # graphics, and hence unambiguously displayable. They are given by code
744 # point order. The second part is the remaining code points, the ordinals
745 # of which are each displayed as 2-digit hex. Blanks are inserted so as
746 # to keep anything from the first part looking like a 2-digit hex number.
749 my @chars = sort { ord $a <=> ord $b } @_;
753 push @chars, chr(258); # This sentinel simplifies the loop termination
755 foreach my $i (0 .. @chars - 1) {
756 my $char = $chars[$i];
760 # We avoid using [:posix:] classes, as these are being tested in this
761 # file. Each equivalence class below is for things that can appear in
762 # a range; those that can't be in a range have class -1. 0 for those
763 # which should be output in hex; and >0 for the other ranges
764 if ($char =~ /[A-Z]/) {
767 elsif ($char =~ /[a-z]/) {
770 elsif ($char =~ /[0-9]/) {
773 # Uncomment to get literal punctuation displayed instead of hex
774 #elsif ($char =~ /[[\]!"#\$\%&\'()*+,.\/:\\;<=>?\@\^_`{|}~-]/) {
775 # $class = -1; # Punct never appears in a range
778 $class = 0; # Output in hex
781 if (! defined $range_start) {
783 $output .= " " . $char;
786 $range_start = ord $char;
787 $start_class = $class;
789 } # A range ends if not consecutive, or the class-type changes
790 elsif (ord $char != ($range_end = ord($chars[$i-1])) + 1
791 || $class != $start_class)
794 # Here, the current character is not in the range. This means the
795 # previous character must have been. Output the range up through
797 my $range_length = $range_end - $range_start + 1;
798 if ($start_class > 0) {
799 $output .= " " . chr($range_start);
800 $output .= "-" . chr($range_end) if $range_length > 1;
803 $output .= sprintf(" %02X", $range_start);
804 $output .= sprintf("-%02X", $range_end) if $range_length > 1;
807 # Handle the new current character, as potentially beginning a new
821 # Displays the string unambiguously. ASCII printables are always output
822 # as-is, though perhaps separated by blanks from other characters. If
823 # entirely printable ASCII, just returns the string. Otherwise if valid
824 # UTF-8 it uses the character names for non-printable-ASCII. Otherwise it
825 # outputs hex for each non-ASCII-printable byte.
827 return $string if $string =~ / ^ [[:print:]]* $/xa;
830 my $prev_was_punct = 1; # Beginning is considered punct
831 if (utf8::valid($string) && utf8::is_utf8($string)) {
833 foreach my $char (split "", $string) {
835 # Keep punctuation adjacent to other characters; otherwise
836 # separate them with a blank
837 if ($char =~ /[[:punct:]]/a) {
841 elsif ($char =~ /[[:print:]]/a) {
842 $result .= " " unless $prev_was_punct;
847 $result .= " " unless $prev_was_punct;
848 $result .= charnames::viacode(ord $char);
855 foreach my $char (split "", $string) {
856 if ($char =~ /[[:punct:]]/a) {
860 elsif ($char =~ /[[:print:]]/a) {
861 $result .= " " unless $prev_was_punct;
866 $result .= " " unless $prev_was_punct;
867 $result .= sprintf("%02X", ord $char);
877 my ($Locale, $i, $pass_fail, $message) = @_;
879 $message = " ($message)" if $message;
881 push @{$Okay{$i}}, $Locale;
884 $Known_bad_locale{$i}{$Locale} = 1 if exists $known_bad_locales{$^O}
885 && $Locale =~ $known_bad_locales{$^O};
886 $Problem{$i}{$Locale} = 1;
887 debug "failed $i ($test_names{$i}) with locale '$Locale'$message\n";
891 sub report_multi_result {
892 my ($Locale, $i, $results_ref) = @_;
894 # $results_ref points to an array, each element of which is a character that was
895 # in error for this test numbered '$i'. If empty, the test passed
899 $message = join " ", "for", disp_chars(@$results_ref);
901 report_result($Locale, $i, @$results_ref == 0, $message);
904 my $first_locales_test_number = $final_without_setlocale + 1;
905 my $locales_test_number;
906 my $not_necessarily_a_problem_test_number;
907 my $first_casing_test_number;
908 my %setlocale_failed; # List of locales that setlocale() didn't work on
910 foreach my $Locale (@Locale) {
911 $locales_test_number = $first_locales_test_number - 1;
913 debug "Locale = $Locale\n";
915 unless (setlocale(&POSIX::LC_ALL, $Locale)) {
916 $setlocale_failed{$Locale} = $Locale;
920 # We test UTF-8 locales only under ':not_characters'; It is easier to
921 # test them in other test files than here. Non- UTF-8 locales are tested
922 # only under plain 'use locale', as otherwise we would have to convert
923 # everything in them to Unicode.
925 my %UPPER = (); # All alpha X for which uc(X) == X and lc(X) != X
926 my %lower = (); # All alpha X for which lc(X) == X and uc(X) != X
927 my %BoThCaSe = (); # All alpha X for which uc(X) == lc(X) == X
929 my $is_utf8_locale = is_locale_utf8($Locale);
931 debug "is utf8 locale? = $is_utf8_locale\n";
933 debug "radix = " . disp_str(localeconv()->{decimal_point}) . "\n";
935 if (! $is_utf8_locale) {
937 @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
938 @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
939 @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
940 @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
941 @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
942 @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
943 @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
944 @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
945 @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
946 @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
947 @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
948 @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
949 @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
950 @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
951 @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
953 # Sieve the uppercase and the lowercase.
955 for (@{$posixes{'word'}}) {
956 if (/[^\d_]/) { # skip digits and the _
967 use locale ':not_characters';
968 @{$posixes{'word'}} = grep /\w/, map { chr } 0..255;
969 @{$posixes{'digit'}} = grep /\d/, map { chr } 0..255;
970 @{$posixes{'space'}} = grep /\s/, map { chr } 0..255;
971 @{$posixes{'alpha'}} = grep /[[:alpha:]]/, map {chr } 0..255;
972 @{$posixes{'alnum'}} = grep /[[:alnum:]]/, map {chr } 0..255;
973 @{$posixes{'ascii'}} = grep /[[:ascii:]]/, map {chr } 0..255;
974 @{$posixes{'blank'}} = grep /[[:blank:]]/, map {chr } 0..255;
975 @{$posixes{'cntrl'}} = grep /[[:cntrl:]]/, map {chr } 0..255;
976 @{$posixes{'graph'}} = grep /[[:graph:]]/, map {chr } 0..255;
977 @{$posixes{'lower'}} = grep /[[:lower:]]/, map {chr } 0..255;
978 @{$posixes{'print'}} = grep /[[:print:]]/, map {chr } 0..255;
979 @{$posixes{'punct'}} = grep /[[:punct:]]/, map {chr } 0..255;
980 @{$posixes{'upper'}} = grep /[[:upper:]]/, map {chr } 0..255;
981 @{$posixes{'xdigit'}} = grep /[[:xdigit:]]/, map {chr } 0..255;
982 @{$posixes{'cased'}} = grep /[[:upper:]]/i, map {chr } 0..255;
983 for (@{$posixes{'word'}}) {
984 if (/[^\d_]/) { # skip digits and the _
995 # Ordered, where possible, in groups of "this is a subset of the next
997 debug ":upper: = ", disp_chars(@{$posixes{'upper'}}), "\n";
998 debug ":lower: = ", disp_chars(@{$posixes{'lower'}}), "\n";
999 debug ":cased: = ", disp_chars(@{$posixes{'cased'}}), "\n";
1000 debug ":alpha: = ", disp_chars(@{$posixes{'alpha'}}), "\n";
1001 debug ":alnum: = ", disp_chars(@{$posixes{'alnum'}}), "\n";
1002 debug " w = ", disp_chars(@{$posixes{'word'}}), "\n";
1003 debug ":graph: = ", disp_chars(@{$posixes{'graph'}}), "\n";
1004 debug ":print: = ", disp_chars(@{$posixes{'print'}}), "\n";
1005 debug " d = ", disp_chars(@{$posixes{'digit'}}), "\n";
1006 debug ":xdigit: = ", disp_chars(@{$posixes{'xdigit'}}), "\n";
1007 debug ":blank: = ", disp_chars(@{$posixes{'blank'}}), "\n";
1008 debug " s = ", disp_chars(@{$posixes{'space'}}), "\n";
1009 debug ":punct: = ", disp_chars(@{$posixes{'punct'}}), "\n";
1010 debug ":cntrl: = ", disp_chars(@{$posixes{'cntrl'}}), "\n";
1011 debug ":ascii: = ", disp_chars(@{$posixes{'ascii'}}), "\n";
1013 foreach (keys %UPPER) {
1015 $BoThCaSe{$_}++ if exists $lower{$_};
1017 foreach (keys %lower) {
1018 $BoThCaSe{$_}++ if exists $UPPER{$_};
1020 foreach (keys %BoThCaSe) {
1026 foreach my $ord ( 0 .. 255 ) {
1027 $Unassigned{chr $ord} = 1;
1029 foreach my $class (keys %posixes) {
1030 foreach my $char (@{$posixes{$class}}) {
1031 delete $Unassigned{$char};
1035 debug "UPPER = ", disp_chars(sort { ord $a <=> ord $b } keys %UPPER), "\n";
1036 debug "lower = ", disp_chars(sort { ord $a <=> ord $b } keys %lower), "\n";
1037 debug "BoThCaSe = ", disp_chars(sort { ord $a <=> ord $b } keys %BoThCaSe), "\n";
1038 debug "Unassigned = ", disp_chars(sort { ord $a <=> ord $b } keys %Unassigned), "\n";
1042 foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
1045 if ($is_utf8_locale) {
1046 use locale ':not_characters';
1047 $ok = $x =~ /[[:upper:]]/;
1048 $fold_ok = $x =~ /[[:lower:]]/i;
1052 $ok = $x =~ /[[:upper:]]/;
1053 $fold_ok = $x =~ /[[:lower:]]/i;
1055 push @failures, $x unless $ok;
1056 push @fold_failures, $x unless $fold_ok;
1058 $locales_test_number++;
1059 $first_casing_test_number = $locales_test_number;
1060 $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/ matches all alpha X for which uc(X) == X and lc(X) != X';
1061 report_multi_result($Locale, $locales_test_number, \@failures);
1063 $locales_test_number++;
1065 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i matches all alpha X for which uc(X) == X and lc(X) != X';
1066 report_multi_result($Locale, $locales_test_number, \@fold_failures);
1069 undef @fold_failures;
1071 foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
1074 if ($is_utf8_locale) {
1075 use locale ':not_characters';
1076 $ok = $x =~ /[[:lower:]]/;
1077 $fold_ok = $x =~ /[[:upper:]]/i;
1081 $ok = $x =~ /[[:lower:]]/;
1082 $fold_ok = $x =~ /[[:upper:]]/i;
1084 push @failures, $x unless $ok;
1085 push @fold_failures, $x unless $fold_ok;
1088 $locales_test_number++;
1089 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/ matches all alpha X for which lc(X) == X and uc(X) != X';
1090 report_multi_result($Locale, $locales_test_number, \@failures);
1092 $locales_test_number++;
1093 $test_names{$locales_test_number} = 'Verify that /[[:upper:]]/i matches all alpha X for which lc(X) == X and uc(X) != X';
1094 report_multi_result($Locale, $locales_test_number, \@fold_failures);
1096 { # Find the alphabetic characters that are not considered alphabetics
1097 # in the default (C) locale.
1102 for (keys %UPPER, keys %lower, keys %BoThCaSe) {
1103 push(@Added_alpha, $_) if (/\W/);
1107 @Added_alpha = sort { ord $a <=> ord $b } @Added_alpha;
1109 debug "Added_alpha = ", disp_chars(@Added_alpha), "\n";
1111 # Cross-check the whole 8-bit character set.
1113 ++$locales_test_number;
1115 $test_names{$locales_test_number} = 'Verify that \w and [:word:] are identical';
1116 for (map { chr } 0..255) {
1117 if ($is_utf8_locale) {
1118 use locale ':not_characters';
1119 push @f, $_ unless /[[:word:]]/ == /\w/;
1122 push @f, $_ unless /[[:word:]]/ == /\w/;
1125 report_multi_result($Locale, $locales_test_number, \@f);
1127 ++$locales_test_number;
1129 $test_names{$locales_test_number} = 'Verify that \d and [:digit:] are identical';
1130 for (map { chr } 0..255) {
1131 if ($is_utf8_locale) {
1132 use locale ':not_characters';
1133 push @f, $_ unless /[[:digit:]]/ == /\d/;
1136 push @f, $_ unless /[[:digit:]]/ == /\d/;
1139 report_multi_result($Locale, $locales_test_number, \@f);
1141 ++$locales_test_number;
1143 $test_names{$locales_test_number} = 'Verify that \s and [:space:] are identical';
1144 for (map { chr } 0..255) {
1145 if ($is_utf8_locale) {
1146 use locale ':not_characters';
1147 push @f, $_ unless /[[:space:]]/ == /\s/;
1150 push @f, $_ unless /[[:space:]]/ == /\s/;
1153 report_multi_result($Locale, $locales_test_number, \@f);
1155 ++$locales_test_number;
1157 $test_names{$locales_test_number} = 'Verify that [:posix:] and [:^posix:] are mutually exclusive';
1158 for (map { chr } 0..255) {
1159 if ($is_utf8_locale) {
1160 use locale ':not_characters';
1161 push @f, $_ unless (/[[:alpha:]]/ xor /[[:^alpha:]]/) ||
1162 (/[[:alnum:]]/ xor /[[:^alnum:]]/) ||
1163 (/[[:ascii:]]/ xor /[[:^ascii:]]/) ||
1164 (/[[:blank:]]/ xor /[[:^blank:]]/) ||
1165 (/[[:cntrl:]]/ xor /[[:^cntrl:]]/) ||
1166 (/[[:digit:]]/ xor /[[:^digit:]]/) ||
1167 (/[[:graph:]]/ xor /[[:^graph:]]/) ||
1168 (/[[:lower:]]/ xor /[[:^lower:]]/) ||
1169 (/[[:print:]]/ xor /[[:^print:]]/) ||
1170 (/[[:space:]]/ xor /[[:^space:]]/) ||
1171 (/[[:upper:]]/ xor /[[:^upper:]]/) ||
1172 (/[[:word:]]/ xor /[[:^word:]]/) ||
1173 (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1175 # effectively is what [:cased:] would be if it existed.
1176 (/[[:upper:]]/i xor /[[:^upper:]]/i);
1179 push @f, $_ unless (/[[:alpha:]]/ xor /[[:^alpha:]]/) ||
1180 (/[[:alnum:]]/ xor /[[:^alnum:]]/) ||
1181 (/[[:ascii:]]/ xor /[[:^ascii:]]/) ||
1182 (/[[:blank:]]/ xor /[[:^blank:]]/) ||
1183 (/[[:cntrl:]]/ xor /[[:^cntrl:]]/) ||
1184 (/[[:digit:]]/ xor /[[:^digit:]]/) ||
1185 (/[[:graph:]]/ xor /[[:^graph:]]/) ||
1186 (/[[:lower:]]/ xor /[[:^lower:]]/) ||
1187 (/[[:print:]]/ xor /[[:^print:]]/) ||
1188 (/[[:space:]]/ xor /[[:^space:]]/) ||
1189 (/[[:upper:]]/ xor /[[:^upper:]]/) ||
1190 (/[[:word:]]/ xor /[[:^word:]]/) ||
1191 (/[[:xdigit:]]/ xor /[[:^xdigit:]]/) ||
1192 (/[[:upper:]]/i xor /[[:^upper:]]/i);
1195 report_multi_result($Locale, $locales_test_number, \@f);
1197 # The rules for the relationships are given in:
1198 # http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html
1201 ++$locales_test_number;
1203 $test_names{$locales_test_number} = 'Verify that [:lower:] contains at least a-z';
1205 if ($is_utf8_locale) {
1206 use locale ':not_characters';
1207 push @f, $_ unless /[[:lower:]]/;
1210 push @f, $_ unless /[[:lower:]]/;
1213 report_multi_result($Locale, $locales_test_number, \@f);
1215 ++$locales_test_number;
1217 $test_names{$locales_test_number} = 'Verify that [:lower:] is a subset of [:alpha:]';
1218 for (map { chr } 0..255) {
1219 if ($is_utf8_locale) {
1220 use locale ':not_characters';
1221 push @f, $_ if /[[:lower:]]/ and ! /[[:alpha:]]/;
1224 push @f, $_ if /[[:lower:]]/ and ! /[[:alpha:]]/;
1227 report_multi_result($Locale, $locales_test_number, \@f);
1229 ++$locales_test_number;
1231 $test_names{$locales_test_number} = 'Verify that [:upper:] contains at least A-Z';
1233 if ($is_utf8_locale) {
1234 use locale ':not_characters';
1235 push @f, $_ unless /[[:upper:]]/;
1238 push @f, $_ unless /[[:upper:]]/;
1241 report_multi_result($Locale, $locales_test_number, \@f);
1243 ++$locales_test_number;
1245 $test_names{$locales_test_number} = 'Verify that [:upper:] is a subset of [:alpha:]';
1246 for (map { chr } 0..255) {
1247 if ($is_utf8_locale) {
1248 use locale ':not_characters';
1249 push @f, $_ if /[[:upper:]]/ and ! /[[:alpha:]]/;
1252 push @f, $_ if /[[:upper:]]/ and ! /[[:alpha:]]/;
1255 report_multi_result($Locale, $locales_test_number, \@f);
1257 ++$locales_test_number;
1259 $test_names{$locales_test_number} = 'Verify that /[[:lower:]]/i is a subset of [:alpha:]';
1260 for (map { chr } 0..255) {
1261 if ($is_utf8_locale) {
1262 use locale ':not_characters';
1263 push @f, $_ if /[[:lower:]]/i and ! /[[:alpha:]]/;
1266 push @f, $_ if /[[:lower:]]/i and ! /[[:alpha:]]/;
1269 report_multi_result($Locale, $locales_test_number, \@f);
1271 ++$locales_test_number;
1273 $test_names{$locales_test_number} = 'Verify that [:alpha:] is a subset of [:alnum:]';
1274 for (map { chr } 0..255) {
1275 if ($is_utf8_locale) {
1276 use locale ':not_characters';
1277 push @f, $_ if /[[:alpha:]]/ and ! /[[:alnum:]]/;
1280 push @f, $_ if /[[:alpha:]]/ and ! /[[:alnum:]]/;
1283 report_multi_result($Locale, $locales_test_number, \@f);
1285 ++$locales_test_number;
1287 $test_names{$locales_test_number} = 'Verify that [:digit:] contains at least 0-9';
1289 if ($is_utf8_locale) {
1290 use locale ':not_characters';
1291 push @f, $_ unless /[[:digit:]]/;
1294 push @f, $_ unless /[[:digit:]]/;
1297 report_multi_result($Locale, $locales_test_number, \@f);
1299 ++$locales_test_number;
1301 $test_names{$locales_test_number} = 'Verify that [:digit:] is a subset of [:alnum:]';
1302 for (map { chr } 0..255) {
1303 if ($is_utf8_locale) {
1304 use locale ':not_characters';
1305 push @f, $_ if /[[:digit:]]/ and ! /[[:alnum:]]/;
1308 push @f, $_ if /[[:digit:]]/ and ! /[[:alnum:]]/;
1311 report_multi_result($Locale, $locales_test_number, \@f);
1313 ++$locales_test_number;
1315 $test_names{$locales_test_number} = 'Verify that [:digit:] matches either 10 or 20 code points';
1316 report_result($Locale, $locales_test_number, @{$posixes{'digit'}} == 10 || @{$posixes{'digit'}} == 20);
1318 ++$locales_test_number;
1320 $test_names{$locales_test_number} = 'Verify that if there is a second set of digits in [:digit:], they are consecutive';
1321 if (@{$posixes{'digit'}} == 20) {
1323 for (map { chr } 0..255) {
1324 next unless /[[:digit:]]/;
1326 if (defined $previous_ord) {
1327 if ($is_utf8_locale) {
1328 use locale ':not_characters';
1329 push @f, $_ if ord $_ != $previous_ord + 1;
1332 push @f, $_ if ord $_ != $previous_ord + 1;
1335 $previous_ord = ord $_;
1338 report_multi_result($Locale, $locales_test_number, \@f);
1340 ++$locales_test_number;
1342 my @xdigit_digits; # :digit: & :xdigit:
1343 $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains one or two blocks of 10 consecutive [:digit:] chars';
1344 for (map { chr } 0..255) {
1345 if ($is_utf8_locale) {
1346 use locale ':not_characters';
1347 # For utf8 locales, we actually use a stricter test: that :digit:
1348 # is a subset of :xdigit:, as we know that only 0-9 should match
1349 push @f, $_ if /[[:digit:]]/ and ! /[[:xdigit:]]/;
1352 push @xdigit_digits, $_ if /[[:digit:]]/ and /[[:xdigit:]]/;
1355 if (! $is_utf8_locale) {
1357 # For non-utf8 locales, @xdigit_digits is a list of the characters
1358 # that are both :xdigit: and :digit:. Because :digit: is stored in
1359 # increasing code point order (unless the tests above failed),
1360 # @xdigit_digits is as well. There should be exactly 10 or
1362 if (@xdigit_digits != 10 && @xdigit_digits != 20) {
1363 @f = @xdigit_digits;
1367 # Look for contiguity in the series, adding any wrong ones to @f
1368 my @temp = @xdigit_digits;
1370 push @f, $temp[1] if ($temp[0] != $temp[1] - 1)
1372 # Skip this test for the 0th character of
1373 # the second block of 10, as it won't be
1374 # contiguous with the previous block
1375 && (! defined $xdigit_digits[10]
1376 || $temp[1] != $xdigit_digits[10]);
1382 report_multi_result($Locale, $locales_test_number, \@f);
1384 ++$locales_test_number;
1386 $test_names{$locales_test_number} = 'Verify that [:xdigit:] contains at least A-F, a-f';
1387 for ('A' .. 'F', 'a' .. 'f') {
1388 if ($is_utf8_locale) {
1389 use locale ':not_characters';
1390 push @f, $_ unless /[[:xdigit:]]/;
1393 push @f, $_ unless /[[:xdigit:]]/;
1396 report_multi_result($Locale, $locales_test_number, \@f);
1398 ++$locales_test_number;
1400 $test_names{$locales_test_number} = 'Verify that any additional members of [:xdigit:], are in groups of 6 consecutive code points';
1403 for my $chr (map { chr } 0..255) {
1404 next unless $chr =~ /[[:xdigit:]]/;
1405 if ($is_utf8_locale) {
1406 next if $chr =~ /[[:digit:]]/;
1409 next if grep { $chr eq $_ } @xdigit_digits;
1411 next if $chr =~ /[A-Fa-f]/;
1412 if (defined $previous_ord) {
1413 if ($is_utf8_locale) {
1414 use locale ':not_characters';
1415 push @f, $chr if ord $chr != $previous_ord + 1;
1418 push @f, $chr if ord $chr != $previous_ord + 1;
1423 undef $previous_ord;
1426 $previous_ord = ord $chr;
1429 report_multi_result($Locale, $locales_test_number, \@f);
1431 ++$locales_test_number;
1433 $test_names{$locales_test_number} = 'Verify that [:xdigit:] is a subset of [:graph:]';
1434 for (map { chr } 0..255) {
1435 if ($is_utf8_locale) {
1436 use locale ':not_characters';
1437 push @f, $_ if /[[:xdigit:]]/ and ! /[[:graph:]]/;
1440 push @f, $_ if /[[:xdigit:]]/ and ! /[[:graph:]]/;
1443 report_multi_result($Locale, $locales_test_number, \@f);
1445 # Note that xdigit doesn't have to be a subset of alnum
1447 ++$locales_test_number;
1449 $test_names{$locales_test_number} = 'Verify that [:punct:] is a subset of [:graph:]';
1450 for (map { chr } 0..255) {
1451 if ($is_utf8_locale) {
1452 use locale ':not_characters';
1453 push @f, $_ if /[[:punct:]]/ and ! /[[:graph:]]/;
1456 push @f, $_ if /[[:punct:]]/ and ! /[[:graph:]]/;
1459 report_multi_result($Locale, $locales_test_number, \@f);
1461 ++$locales_test_number;
1463 $test_names{$locales_test_number} = 'Verify that the space character is not in [:graph:]';
1464 if ($is_utf8_locale) {
1465 use locale ':not_characters';
1466 push @f, " " if " " =~ /[[:graph:]]/;
1469 push @f, " " if " " =~ /[[:graph:]]/;
1471 report_multi_result($Locale, $locales_test_number, \@f);
1473 ++$locales_test_number;
1475 $test_names{$locales_test_number} = 'Verify that [:space:] contains at least [\f\n\r\t\cK ]';
1476 for (' ', "\f", "\n", "\r", "\t", "\cK") {
1477 if ($is_utf8_locale) {
1478 use locale ':not_characters';
1479 push @f, $_ unless /[[:space:]]/;
1482 push @f, $_ unless /[[:space:]]/;
1485 report_multi_result($Locale, $locales_test_number, \@f);
1487 ++$locales_test_number;
1489 $test_names{$locales_test_number} = 'Verify that [:blank:] contains at least [\t ]';
1491 if ($is_utf8_locale) {
1492 use locale ':not_characters';
1493 push @f, $_ unless /[[:blank:]]/;
1496 push @f, $_ unless /[[:blank:]]/;
1499 report_multi_result($Locale, $locales_test_number, \@f);
1501 ++$locales_test_number;
1503 $test_names{$locales_test_number} = 'Verify that [:blank:] is a subset of [:space:]';
1504 for (map { chr } 0..255) {
1505 if ($is_utf8_locale) {
1506 use locale ':not_characters';
1507 push @f, $_ if /[[:blank:]]/ and ! /[[:space:]]/;
1510 push @f, $_ if /[[:blank:]]/ and ! /[[:space:]]/;
1513 report_multi_result($Locale, $locales_test_number, \@f);
1515 ++$locales_test_number;
1517 $test_names{$locales_test_number} = 'Verify that [:graph:] is a subset of [:print:]';
1518 for (map { chr } 0..255) {
1519 if ($is_utf8_locale) {
1520 use locale ':not_characters';
1521 push @f, $_ if /[[:graph:]]/ and ! /[[:print:]]/;
1524 push @f, $_ if /[[:graph:]]/ and ! /[[:print:]]/;
1527 report_multi_result($Locale, $locales_test_number, \@f);
1529 ++$locales_test_number;
1531 $test_names{$locales_test_number} = 'Verify that the space character is in [:print:]';
1532 if ($is_utf8_locale) {
1533 use locale ':not_characters';
1534 push @f, " " if " " !~ /[[:print:]]/;
1537 push @f, " " if " " !~ /[[:print:]]/;
1539 report_multi_result($Locale, $locales_test_number, \@f);
1541 ++$locales_test_number;
1543 $test_names{$locales_test_number} = 'Verify that isn\'t both [:cntrl:] and [:print:]';
1544 for (map { chr } 0..255) {
1545 if ($is_utf8_locale) {
1546 use locale ':not_characters';
1547 push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1550 push @f, $_ if (/[[:print:]]/ and /[[:cntrl:]]/);
1553 report_multi_result($Locale, $locales_test_number, \@f);
1555 ++$locales_test_number;
1557 $test_names{$locales_test_number} = 'Verify that isn\'t both [:alpha:] and [:digit:]';
1558 for (map { chr } 0..255) {
1559 if ($is_utf8_locale) {
1560 use locale ':not_characters';
1561 push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1564 push @f, $_ if /[[:alpha:]]/ and /[[:digit:]]/;
1567 report_multi_result($Locale, $locales_test_number, \@f);
1569 ++$locales_test_number;
1571 $test_names{$locales_test_number} = 'Verify that isn\'t both [:alnum:] and [:punct:]';
1572 for (map { chr } 0..255) {
1573 if ($is_utf8_locale) {
1574 use locale ':not_characters';
1575 push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1578 push @f, $_ if /[[:alnum:]]/ and /[[:punct:]]/;
1581 report_multi_result($Locale, $locales_test_number, \@f);
1583 ++$locales_test_number;
1585 $test_names{$locales_test_number} = 'Verify that isn\'t both [:xdigit:] and [:punct:]';
1586 for (map { chr } 0..255) {
1587 if ($is_utf8_locale) {
1588 use locale ':not_characters';
1589 push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1592 push @f, $_ if (/[[:punct:]]/ and /[[:xdigit:]]/);
1595 report_multi_result($Locale, $locales_test_number, \@f);
1597 ++$locales_test_number;
1599 $test_names{$locales_test_number} = 'Verify that isn\'t both [:graph:] and [:space:]';
1600 for (map { chr } 0..255) {
1601 if ($is_utf8_locale) {
1602 use locale ':not_characters';
1603 push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1606 push @f, $_ if (/[[:graph:]]/ and /[[:space:]]/);
1609 report_multi_result($Locale, $locales_test_number, \@f);
1611 foreach ($first_casing_test_number..$locales_test_number) {
1612 $problematical_tests{$_} = 1;
1616 # Test for read-only scalars' locale vs non-locale comparisons.
1622 if ($is_utf8_locale) {
1623 use locale ':not_characters';
1624 $ok = ($a cmp "qwerty") == 0;
1628 $ok = ($a cmp "qwerty") == 0;
1630 report_result($Locale, ++$locales_test_number, $ok);
1631 $test_names{$locales_test_number} = 'Verify that cmp works with a read-only scalar; no- vs locale';
1635 my ($from, $to, $lesser, $greater,
1636 @test, %test, $test, $yes, $no, $sign);
1638 ++$locales_test_number;
1639 $test_names{$locales_test_number} = 'Verify that "le", "ne", etc work';
1640 $not_necessarily_a_problem_test_number = $locales_test_number;
1643 $from = int(($_*@{$posixes{'word'}})/10);
1644 $to = $from + int(@{$posixes{'word'}}/10);
1645 $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1646 $lesser = join('', @{$posixes{'word'}}[$from..$to]);
1647 # Select a slice one character on.
1649 $to = $#{$posixes{'word'}} if ($to > $#{$posixes{'word'}});
1650 $greater = join('', @{$posixes{'word'}}[$from..$to]);
1651 if ($is_utf8_locale) {
1652 use locale ':not_characters';
1653 ($yes, $no, $sign) = ($lesser lt $greater
1655 : ("not ", " ", -1));
1659 ($yes, $no, $sign) = ($lesser lt $greater
1661 : ("not ", " ", -1));
1663 # all these tests should FAIL (return 0). Exact lt or gt cannot
1664 # be tested because in some locales, say, eacute and E may test
1668 $no.' ($lesser le $greater)', # 1
1669 'not ($lesser ne $greater)', # 2
1670 ' ($lesser eq $greater)', # 3
1671 $yes.' ($lesser ge $greater)', # 4
1672 $yes.' ($lesser ge $greater)', # 5
1673 $yes.' ($greater le $lesser )', # 7
1674 'not ($greater ne $lesser )', # 8
1675 ' ($greater eq $lesser )', # 9
1676 $no.' ($greater ge $lesser )', # 10
1677 'not (($lesser cmp $greater) == -($sign))' # 11
1679 @test{@test} = 0 x @test;
1681 for my $ti (@test) {
1682 if ($is_utf8_locale) {
1683 use locale ':not_characters';
1684 $test{$ti} = eval $ti;
1687 # Already in 'use locale';
1688 $test{$ti} = eval $ti;
1690 $test ||= $test{$ti}
1692 report_result($Locale, $locales_test_number, $test == 0);
1694 debug "lesser = '$lesser'\n";
1695 debug "greater = '$greater'\n";
1696 debug "lesser cmp greater = ",
1697 $lesser cmp $greater, "\n";
1698 debug "greater cmp lesser = ",
1699 $greater cmp $lesser, "\n";
1700 debug "(greater) from = $from, to = $to\n";
1701 for my $ti (@test) {
1702 debugf("# %-40s %-4s", $ti,
1703 $test{$ti} ? 'FAIL' : 'ok');
1704 if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
1705 debugf("(%s == %4d)", $1, eval $1);
1747 if (! $is_utf8_locale) {
1750 my ($x, $y) = (1.23, 1.23);
1753 printf ''; # printf used to reset locale to "C"
1758 my $z = sprintf ''; # sprintf used to reset locale to "C"
1765 local $SIG{__WARN__} =
1771 # The == (among other ops) used to warn for locales
1772 # that had something else than "." as the radix character.
1796 $ok12 = abs(($f + $g) - 3.57) < 0.01;
1798 $ok14 = $ok14_5 = $ok15 = $ok16 = 1; # Skip for non-utf8 locales
1802 $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
1804 $ok18 = $j eq sprintf("%g:%g", $h, $i);
1807 use locale ':not_characters';
1809 my ($x, $y) = (1.23, 1.23);
1811 printf ''; # printf used to reset locale to "C"
1816 my $z = sprintf ''; # sprintf used to reset locale to "C"
1822 local $SIG{__WARN__} =
1848 $ok12 = abs(($f + $g) - 3.57) < 0.01;
1851 # Look for non-ASCII error messages, and verify that the first
1852 # such is in UTF-8 (the others almost certainly will be like the
1853 # first). This is only done if the current locale has LC_MESSAGES
1856 if (setlocale(&POSIX::LC_MESSAGES, $Locale)) {
1857 foreach my $err (keys %!) {
1859 $! = eval "&Errno::$err"; # Convert to strerror() output
1860 my $strerror = "$!";
1861 if ("$strerror" =~ /\P{ASCII}/) {
1862 $ok14 = utf8::is_utf8($strerror);
1864 $ok14_5 = "$!" !~ /\P{ASCII}/;
1870 # Similarly, we verify that a non-ASCII radix is in UTF-8. This
1871 # also catches if there is a disparity between sprintf and
1874 my $string_g = "$g";
1875 my $sprintf_g = sprintf("%g", $g);
1877 $ok15 = $string_g =~ / ^ \p{ASCII}+ $ /x || utf8::is_utf8($string_g);
1878 $ok16 = $sprintf_g eq $string_g;
1882 $ok17 = "1.5:1.25" eq sprintf("%g:%g", $h, $i);
1884 $ok18 = $j eq sprintf("%g:%g", $h, $i);
1888 if (setlocale(&POSIX::LC_TIME, $Locale)) { # These tests aren't affected by
1890 my @times = CORE::localtime();
1893 $ok19 = POSIX::strftime("%p", @times) ne "%p"; # [perl #119425]
1894 my $date = POSIX::strftime("'%A' '%B' '%Z' '%p'", @times);
1895 debug("'Day' 'Month' 'TZ' 'am/pm' = ", disp_str($date));
1897 # If there is any non-ascii, it better be UTF-8 in a UTF-8 locale, and
1898 # not UTF-8 if the locale isn't UTF-8.
1899 $ok20 = $date =~ / ^ \p{ASCII}+ $ /x
1900 || $is_utf8_locale == utf8::is_utf8($date);
1904 foreach my $err (keys %!) {
1907 $! = eval "&Errno::$err"; # Convert to strerror() output
1908 my $strerror = "$!";
1909 if ("$strerror" =~ /\P{ASCII}/) {
1915 report_result($Locale, ++$locales_test_number, $ok1);
1916 $test_names{$locales_test_number} = 'Verify that an intervening printf doesn\'t change assignment results';
1917 my $first_a_test = $locales_test_number;
1919 debug "$first_a_test..$locales_test_number: \$a = $a, \$b = $b, Locale = $Locale\n";
1921 report_result($Locale, ++$locales_test_number, $ok2);
1922 $test_names{$locales_test_number} = 'Verify that an intervening sprintf doesn\'t change assignment results';
1924 my $first_c_test = $locales_test_number;
1926 $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
1927 if ($Config{usequadmath}) {
1928 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1929 report_result($Locale, $locales_test_number, 1);
1931 report_result($Locale, $locales_test_number, $ok3);
1932 $problematical_tests{$locales_test_number} = 1;
1935 $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
1936 if ($Config{usequadmath}) {
1937 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1938 report_result($Locale, $locales_test_number, 1);
1940 report_result($Locale, $locales_test_number, $ok4);
1941 $problematical_tests{$locales_test_number} = 1;
1944 report_result($Locale, ++$locales_test_number, $ok5);
1945 $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
1946 $problematical_tests{$locales_test_number} = 1;
1948 debug "$first_c_test..$locales_test_number: \$c = $c, \$d = $d, Locale = $Locale\n";
1950 report_result($Locale, ++$locales_test_number, $ok6);
1951 $test_names{$locales_test_number} = 'Verify that can assign stringified under inner no-locale block';
1952 my $first_e_test = $locales_test_number;
1954 report_result($Locale, ++$locales_test_number, $ok7);
1955 $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
1957 $test_names{++$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
1958 if ($Config{usequadmath}) {
1959 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1960 report_result($Locale, $locales_test_number, 1);
1962 report_result($Locale, $locales_test_number, $ok8);
1963 $problematical_tests{$locales_test_number} = 1;
1966 debug "$first_e_test..$locales_test_number: \$e = $e, no locale\n";
1968 report_result($Locale, ++$locales_test_number, $ok9);
1969 $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a constant';
1970 $problematical_tests{$locales_test_number} = 1;
1971 my $first_f_test = $locales_test_number;
1973 report_result($Locale, ++$locales_test_number, $ok10);
1974 $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
1975 $problematical_tests{$locales_test_number} = 1;
1977 $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';
1978 if ($Config{usequadmath}) {
1979 print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
1980 report_result($Locale, $locales_test_number, 1);
1982 report_result($Locale, $locales_test_number, $ok11);
1983 $problematical_tests{$locales_test_number} = 1;
1986 report_result($Locale, ++$locales_test_number, $ok12);
1987 $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';
1988 $problematical_tests{$locales_test_number} = 1;
1990 report_result($Locale, ++$locales_test_number, $ok13);
1991 $test_names{$locales_test_number} = 'Verify that don\'t get warning under "==" even if radix is not a dot';
1992 $problematical_tests{$locales_test_number} = 1;
1994 report_result($Locale, ++$locales_test_number, $ok14);
1995 $test_names{$locales_test_number} = 'Verify that non-ASCII UTF-8 error messages are in UTF-8';
1997 report_result($Locale, ++$locales_test_number, $ok14_5);
1998 $test_names{$locales_test_number} = '... and are ASCII outside "use locale"';
2000 report_result($Locale, ++$locales_test_number, $ok15);
2001 $test_names{$locales_test_number} = 'Verify that a number with a UTF-8 radix has a UTF-8 stringification';
2003 report_result($Locale, ++$locales_test_number, $ok16);
2004 $test_names{$locales_test_number} = 'Verify that a sprintf of a number with a UTF-8 radix yields UTF-8';
2006 report_result($Locale, ++$locales_test_number, $ok17);
2007 $test_names{$locales_test_number} = 'Verify that a sprintf of a number outside locale scope uses a dot radix';
2009 report_result($Locale, ++$locales_test_number, $ok18);
2010 $test_names{$locales_test_number} = 'Verify that a sprintf of a number back within locale scope uses locale radix';
2012 report_result($Locale, ++$locales_test_number, $ok19);
2013 $test_names{$locales_test_number} = 'Verify that strftime doesn\'t return "%p" in locales where %p is empty';
2015 report_result($Locale, ++$locales_test_number, $ok20);
2016 $test_names{$locales_test_number} = 'Verify that strftime returns date with UTF-8 flag appropriately set';
2017 $problematical_tests{$locales_test_number} = 1; # This is broken in
2020 report_result($Locale, ++$locales_test_number, $ok21);
2021 $test_names{$locales_test_number} = '"$!" is ASCII only outside of locale scope';
2023 debug "$first_f_test..$locales_test_number: \$f = $f, \$g = $g, back to locale = $Locale\n";
2025 # Does taking lc separately differ from taking
2026 # the lc "in-line"? (This was the bug 19990704.002, change #3568.)
2027 # The bug was in the caching of the 'o'-magic.
2028 if (! $is_utf8_locale) {
2034 return $lc0 cmp $lc1;
2038 return lc($_[0]) cmp lc($_[1]);
2045 report_result($Locale, ++$locales_test_number,
2046 lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
2047 lcA($x, $z) == 0 && lcB($x, $z) == 0);
2050 use locale ':not_characters';
2055 return $lc0 cmp $lc1;
2059 return lc($_[0]) cmp lc($_[1]);
2066 report_result($Locale, ++$locales_test_number,
2067 lcC($x, $y) == 1 && lcD($x, $y) == 1 ||
2068 lcC($x, $z) == 0 && lcD($x, $z) == 0);
2070 $test_names{$locales_test_number} = 'Verify "lc(foo) cmp lc(bar)" is the same as using intermediaries for the cmp';
2072 # Does lc of an UPPER (if different from the UPPER) match
2073 # case-insensitively the UPPER, and does the UPPER match
2074 # case-insensitively the lc of the UPPER. And vice versa.
2078 my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
2081 ++$locales_test_number;
2082 $test_names{$locales_test_number} = 'Verify case insensitive matching works';
2083 foreach my $x (sort { ord $a <=> ord $b } keys %UPPER) {
2084 if (! $is_utf8_locale) {
2086 next unless uc $y eq $x;
2087 debug_more( "UPPER=", disp_chars(($x)),
2088 "; lc=", disp_chars(($y)), "; ",
2089 "; fc=", disp_chars((fc $x)), "; ",
2090 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2091 $x =~ /\Q$y/i ? 1 : 0,
2093 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2094 $y =~ /\Q$x/i ? 1 : 0,
2097 # If $x and $y contain regular expression characters
2098 # AND THEY lowercase (/i) to regular expression characters,
2099 # regcomp() will be mightily confused. No, the \Q doesn't
2100 # help here (maybe regex engine internal lowercasing
2101 # is done after the \Q?) An example of this happening is
2102 # the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
2103 # the chr(173) (the "[") is the lowercase of the chr(235).
2105 # Similarly losing EBCDIC locales include cs_cz, cs_CZ,
2106 # el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
2107 # et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
2108 # mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
2109 # pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
2110 # sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
2112 # Similar things can happen even under (bastardised)
2113 # non-EBCDIC locales: in many European countries before the
2114 # advent of ISO 8859-x nationally customised versions of
2115 # ISO 646 were devised, reusing certain punctuation
2116 # characters for modified characters needed by the
2117 # country/language. For example, the "|" might have
2118 # stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
2120 if ($x =~ $re || $y =~ $re) {
2121 print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2124 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2126 # fc is not a locale concept, so Perl uses lc for it.
2127 push @f, $x unless lc $x eq fc $x;
2130 use locale ':not_characters';
2132 next unless uc $y eq $x;
2133 debug_more( "UPPER=", disp_chars(($x)),
2134 "; lc=", disp_chars(($y)), "; ",
2135 "; fc=", disp_chars((fc $x)), "; ",
2136 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2137 $x =~ /\Q$y/i ? 1 : 0,
2139 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2140 $y =~ /\Q$x/i ? 1 : 0,
2143 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2145 # The places where Unicode's lc is different from fc are
2146 # skipped here by virtue of the 'next unless uc...' line above
2147 push @f, $x unless lc $x eq fc $x;
2151 foreach my $x (sort { ord $a <=> ord $b } keys %lower) {
2152 if (! $is_utf8_locale) {
2154 next unless lc $y eq $x;
2155 debug_more( "lower=", disp_chars(($x)),
2156 "; uc=", disp_chars(($y)), "; ",
2157 "; fc=", disp_chars((fc $x)), "; ",
2158 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2159 $x =~ /\Q$y/i ? 1 : 0,
2161 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2162 $y =~ /\Q$x/i ? 1 : 0,
2164 if ($x =~ $re || $y =~ $re) { # See above.
2165 print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
2168 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2170 push @f, $x unless lc $x eq fc $x;
2173 use locale ':not_characters';
2175 next unless lc $y eq $x;
2176 debug_more( "lower=", disp_chars(($x)),
2177 "; uc=", disp_chars(($y)), "; ",
2178 "; fc=", disp_chars((fc $x)), "; ",
2179 disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
2180 $x =~ /\Q$y/i ? 1 : 0,
2182 disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
2183 $y =~ /\Q$x/i ? 1 : 0,
2185 push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
2187 push @f, $x unless lc $x eq fc $x;
2190 report_multi_result($Locale, $locales_test_number, \@f);
2191 $problematical_tests{$locales_test_number} = 1;
2197 ++$locales_test_number;
2198 $test_names{$locales_test_number} = 'Verify atof with locale radix and negative exponent';
2199 $problematical_tests{$locales_test_number} = 1;
2201 my $radix = POSIX::localeconv()->{decimal_point};
2203 "3.14e+9", "3${radix}14e+9", "3.14e-9", "3${radix}14e-9",
2204 "-3.14e+9", "-3${radix}14e+9", "-3.14e-9", "-3${radix}14e-9",
2207 if (! $is_utf8_locale) {
2209 for my $num (@nums) {
2211 unless sprintf("%g", $num) =~ /3.+14/;
2215 use locale ':not_characters';
2216 for my $num (@nums) {
2218 unless sprintf("%g", $num) =~ /3.+14/;
2222 if ($Config{usequadmath}) {
2223 print "# Skip: no locale radix with usequadmath ($Locale)\n";
2224 report_result($Locale, $locales_test_number, 1);
2226 report_result($Locale, $locales_test_number, @f == 0);
2228 print "# failed $locales_test_number locale '$Locale' numbers @f\n"
2234 my $final_locales_test_number = $locales_test_number;
2236 # Recount the errors.
2239 foreach $test_num ($first_locales_test_number..$final_locales_test_number) {
2240 if (%setlocale_failed) {
2243 elsif ($Problem{$test_num}
2244 || ! defined $Okay{$test_num}
2245 || ! @{$Okay{$test_num}})
2247 if (defined $not_necessarily_a_problem_test_number
2248 && $test_num == $not_necessarily_a_problem_test_number)
2250 print "# The failure of test $not_necessarily_a_problem_test_number is not necessarily fatal.\n";
2251 print "# It usually indicates a problem in the environment,\n";
2252 print "# not in Perl itself.\n";
2255 # If there are any locales that pass this test, or are known-bad, it
2256 # may be that there are enough passes that we TODO the failure.
2257 if (($Okay{$test_num} || $Known_bad_locale{$test_num})
2258 && grep { $_ == $test_num } keys %problematical_tests)
2260 no warnings 'experimental::autoderef';
2262 # Don't count the known-bad failures when calculating the
2263 # percentage that fail.
2264 my $known_failures = (exists $Known_bad_locale{$test_num})
2265 ? scalar(keys $Known_bad_locale{$test_num})
2267 my $adjusted_failures = scalar(keys $Problem{$test_num})
2270 # Specially handle failures where only known-bad locales fail.
2271 # This makes the diagnositics clearer.
2272 if ($adjusted_failures <= 0) {
2273 print "not ok $test_num $test_names{$test_num} # TODO fails only on ",
2274 "known bad locales: ",
2275 join " ", keys $Known_bad_locale{$test_num}, "\n";
2279 # Round to nearest .1%
2280 my $percent_fail = (int(.5 + (1000 * $adjusted_failures
2281 / scalar(@Locale))))
2283 if ($percent_fail < $acceptable_failure_percentage) {
2285 $test_names{$test_num} .= 'TODO';
2286 print "# ", 100 - $percent_fail, "% of locales not known to be problematic on this platform\n";
2287 print "# pass the following test, so it is likely that the failures\n";
2288 print "# are errors in the locale definitions. The test is marked TODO, as the\n";
2289 print "# problem is not likely to be Perl's\n";
2293 print "# $percent_fail% of locales (",
2294 scalar(keys $Problem{$test_num}),
2297 ") fail the above test (TODO cut-off is ",
2298 $acceptable_failure_percentage,
2304 print "# The code points that had this failure are given above. Look for lines\n";
2305 print "# that match 'failed $test_num'\n";
2308 print "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2309 print "# Then look at that output for lines that match 'failed $test_num'\n";
2313 print "ok $test_num";
2314 if (defined $test_names{$test_num}) {
2315 # If TODO is in the test name, make it thus
2316 my $todo = $test_names{$test_num} =~ s/TODO\s*//;
2317 print " $test_names{$test_num}";
2318 print " # TODO" if $todo;
2323 $test_num = $final_locales_test_number;
2325 unless ( $^O =~ m!^(dragonfly|openbsd|bitrig|mirbsd)$! ) {
2329 local $SIG{__WARN__} = sub {
2330 $warned = $_[0] =~ /uninitialized/;
2332 my $z = "y" . setlocale(&POSIX::LC_ALL, "xyzzy");
2333 ok($warned, "variable set to setlocale(BAD LOCALE) is considered uninitialized");
2336 # Test that tainting and case changing works on utf8 strings. These tests are
2337 # placed last to avoid disturbing the hard-coded test numbers that existed at
2338 # the time these were added above this in this file.
2339 # This also tests that locale overrides unicode_strings in the same scope for
2341 setlocale(&POSIX::LC_ALL, "C");
2344 use feature 'unicode_strings';
2346 foreach my $function ("uc", "ucfirst", "lc", "lcfirst", "fc") {
2347 my @list; # List of code points to test for $function
2349 # Used to calculate the changed case for ASCII characters by using the
2350 # ord, instead of using one of the functions under test.
2351 my $ascii_case_change_delta;
2352 my $above_latin1_case_change_delta; # Same for the specific ords > 255
2355 # We test an ASCII character, which should change case;
2356 # a Latin1 character, which shouldn't change case under this C locale,
2357 # an above-Latin1 character that when the case is changed would cross
2358 # the 255/256 boundary, so doesn't change case
2359 # (the \x{149} is one of these, but changes into 2 characters, the
2360 # first one of which doesn't cross the boundary.
2361 # the final one in each list is an above-Latin1 character whose case
2362 # does change. The code below uses its position in its list as a
2363 # marker to indicate that it, unlike the other code points above
2364 # ASCII, has a successful case change
2366 # All casing operations under locale (but not :not_characters) should
2368 if ($function =~ /^u/) {
2369 @list = ("", "a", "\xe0", "\xff", "\x{fb00}", "\x{149}", "\x{101}");
2370 $ascii_case_change_delta = -32;
2371 $above_latin1_case_change_delta = -1;
2374 @list = ("", "A", "\xC0", "\x{17F}", "\x{100}");
2375 $ascii_case_change_delta = +32;
2376 $above_latin1_case_change_delta = +1;
2378 foreach my $is_utf8_locale (0 .. 1) {
2379 foreach my $j (0 .. $#list) {
2380 my $char = $list[$j];
2382 for my $encoded_in_utf8 (0 .. 1) {
2385 if (! $is_utf8_locale) {
2386 no warnings 'locale';
2387 $should_be = ($j == $#list)
2388 ? chr(ord($char) + $above_latin1_case_change_delta)
2389 : (length $char == 0 || ord($char) > 127)
2391 : chr(ord($char) + $ascii_case_change_delta);
2393 # This monstrosity is in order to avoid using an eval,
2394 # which might perturb the results
2395 $changed = ($function eq "uc")
2397 : ($function eq "ucfirst")
2399 : ($function eq "lc")
2401 : ($function eq "lcfirst")
2403 : ($function eq "fc")
2405 : die("Unexpected function \"$function\"");
2411 # For utf8-locales the case changing functions
2412 # should work just like they do outside of locale.
2413 # Can use eval here because not testing it when
2415 $should_be = eval "$function('$char')";
2416 die "Unexpected eval error $@ from 'eval \"$function('$char')\"'" if $@;
2419 use locale ':not_characters';
2420 $changed = ($function eq "uc")
2422 : ($function eq "ucfirst")
2424 : ($function eq "lc")
2426 : ($function eq "lcfirst")
2428 : ($function eq "fc")
2430 : die("Unexpected function \"$function\"");
2432 ok($changed eq $should_be,
2433 "$function(\"$char\") in C locale "
2434 . (($is_utf8_locale)
2435 ? "(use locale ':not_characters'"
2437 . (($encoded_in_utf8)
2438 ? "; encoded in utf8)"
2439 : "; not encoded in utf8)")
2440 . " should be \"$should_be\", got \"$changed\"");
2442 # Tainting shouldn't happen for use locale :not_character
2445 ? check_taint($changed)
2446 : check_taint_not($changed);
2448 # Use UTF-8 next time through the loop
2449 utf8::upgrade($char);
2456 # Give final advice.
2460 foreach ($first_locales_test_number..$final_locales_test_number) {
2462 my @f = sort keys %{ $Problem{$_} };
2464 # Don't list the failures caused by known-bad locales.
2465 if (exists $known_bad_locales{$^O}) {
2466 @f = grep { $_ !~ $known_bad_locales{$^O} } @f;
2469 my $f = join(" ", @f);
2470 $f =~ s/(.{50,60}) /$1\n#\t/g;
2473 "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
2475 "# on your system may have errors because the locale test $_\n",
2476 "# \"$test_names{$_}\"\n",
2477 "# failed in ", (@f == 1 ? "that locale" : "those locales"),
2481 # If your users are not using these locales you are safe for the moment,
2482 # but please report this failure first to perlbug\@perl.com using the
2483 # perlbug script (as described in the INSTALL file) so that the exact
2484 # details of the failures can be sorted out first and then your operating
2485 # system supplier can be alerted about these anomalies.
2492 # Tell which locales were okay and which were not.
2497 foreach my $l (@Locale) {
2499 if ($setlocale_failed{$l}) {
2504 ($first_locales_test_number..$final_locales_test_number)
2506 $p++ if $Problem{$t}{$l};
2509 push @s, $l if $p == 0;
2510 push @F, $l unless $p == 0;
2514 my $s = join(" ", @s);
2515 $s =~ s/(.{50,60}) /$1\n#\t/g;
2518 "# The following locales\n#\n",
2520 "# tested okay.\n#\n",
2522 print "# None of your locales were fully okay.\n";
2526 my $F = join(" ", @F);
2527 $F =~ s/(.{50,60}) /$1\n#\t/g;
2531 $details = "# For more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=1.\n";
2533 elsif ($debug == 1) {
2534 $details = "# For even more details, rerun, with environment variable PERL_DEBUG_FULL_TEST=2.\n";
2538 "# The following locales\n#\n",
2540 "# had problems.\n#\n",
2543 print "# None of your locales were broken.\n";
2547 if (exists $known_bad_locales{$^O} && ! %Known_bad_locale) {
2549 print "ok $test_num $^O no longer has known bad locales # TODO\n";
2552 print "1..$test_num\n";