lib/locale.t

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