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