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