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