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