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