lib/locale.t

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