lib/locale.t

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