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