t/re/fold_grind.t

   1 # Grind out a lot of combinatoric tests for folding.
   2
   3 binmode STDOUT, ":utf8";
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = '../lib';
   8     require './test.pl';
   9     require Config; import Config;
  10     skip_all_if_miniperl("no dynamic loading on miniperl, no Encode nor POSIX");
  11 }
  12
  13 use charnames ":full";
  14
  15 my $DEBUG = 0;  # Outputs extra information for debugging this .t
  16
  17 use strict;
  18 use warnings;
  19 use Encode;
  20 use POSIX;
  21
  22 # Special-cased characters in the .c's that we want to make sure get tested.
  23 my %be_sure_to_test = (
  24         "\xDF" => 1, # LATIN_SMALL_LETTER_SHARP_S
  25         "\x{1E9E}" => 1, # LATIN_CAPITAL_LETTER_SHARP_S
  26         "\x{390}" => 1, # GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
  27         "\x{3B0}" => 1, # GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
  28         "\x{1FD3}" => 1, # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
  29         "\x{1FE3}" => 1, # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
  30     );
  31
  32
  33 # Tests both unicode and not, so make sure not implicitly testing unicode
  34 no feature 'unicode_strings';
  35
  36 # Case-insensitive matching is a large and complicated issue.  Perl does not
  37 # implement it fully, properly.  For example, it doesn't include normalization
  38 # as part of the equation.  To test every conceivable combination is clearly
  39 # impossible; these tests are mostly drawn from visual inspection of the code
  40 # and experience, trying to exercise all areas.
  41
  42 # There are three basic ranges of characters that Perl may treat differently:
  43 # 1) Invariants under utf8 which on ASCII-ish machines are ASCII, and are
  44 #    referred to here as ASCII.  On EBCDIC machines, the non-ASCII invariants
  45 #    are all controls that fold to themselves.
  46 my $ASCII = 1;
  47
  48 # 2) Other characters that fit into a byte but are different in utf8 than not;
  49 #    here referred to, taking some liberties, as Latin1.
  50 my $Latin1 = 2;
  51
  52 # 3) Characters that won't fit in a byte; here referred to as Unicode
  53 my $Unicode = 3;
  54
  55 # Within these basic groups are equivalence classes that testing any character
  56 # in is likely to lead to the same results as any other character.  This is
  57 # used to cut down the number of tests needed, unless PERL_RUN_SLOW_TESTS is
  58 # set.
  59 my $skip_apparently_redundant = ! $ENV{PERL_RUN_SLOW_TESTS};
  60
  61 # Additionally parts of this test run a lot of subtests, outputting the
  62 # resulting TAP can be expensive so the tests are summarised internally. The
  63 # PERL_DEBUG_FULL_TEST environment variable can be set to produce the full
  64 # output for debugging purposes.
  65
  66 sub range_type {
  67     my $ord = ord shift;
  68
  69     return $ASCII if $ord < 128;
  70     return $Latin1 if $ord < 256;
  71     return $Unicode;
  72 }
  73
  74 sub numerically {
  75     return $a <=> $b
  76 }
  77
  78 my $list_all_tests = $ENV{PERL_DEBUG_FULL_TEST} || $DEBUG;
  79 $| = 1 if $list_all_tests;
  80
  81 # Significant time is saved by not outputting each test but grouping the
  82 # output into subtests
  83 my $okays;          # Number of ok's in current subtest
  84 my $this_iteration; # Number of possible tests in current subtest
  85 my $count=0;        # Number of subtests = number of total tests
  86
  87 sub run_test($$$) {
  88     my ($test, $todo, $debug) = @_;
  89
  90     $debug = "" unless $DEBUG;
  91     my $res = eval $test;
  92
  93     if (!$res || $list_all_tests) {
  94       # Failed or debug; output the result
  95       $count++;
  96       ok($res, "$test; $debug");
  97     } else {
  98       # Just count the test as passed
  99       $okays++;
 100     }
 101     $this_iteration++;
 102 }
 103
 104 my %has_test_by_participants;   # Makes sure has tests for each range and each
 105                                 # number of characters that fold to the same
 106                                 # thing
 107 my %has_test_by_byte_count; # Makes sure has tests for each combination of
 108                             # n bytes folds to m bytes
 109
 110 my %tests; # The set of tests.
 111 # Each key is a code point that folds to something else.
 112 # Each value is a list of things that the key folds to.  If the 'thing' is a
 113 # single code point, it is that ordinal.  If it is a multi-char fold, it is an
 114 # ordered list of the code points in that fold.  Here's an example for 'S':
 115 #  '83' => [ 115, 383 ]
 116 #
 117 # And one for a multi-char fold: \xDF
 118 #  223 => [
 119 #            [  # 'ss'
 120 #                83,
 121 #                83
 122 #            ],
 123 #            [  # 'SS'
 124 #                115,
 125 #                115
 126 #            ],
 127 #            [  # LATIN SMALL LETTER LONG S
 128 #                383,
 129 #                383
 130 #            ],
 131 #          7838 # LATIN_CAPITAL_LETTER_SHARP_S
 132 #        ],
 133
 134 my %inverse_folds;  # keys are strings of the folded-to;
 135                     # values are lists of characters that fold to them
 136
 137 sub add_test($@) {
 138     my ($to, @from) = @_;
 139
 140     # Called to cause the input to be tested by adding to %tests.  @from is
 141     # the list of characters that fold to the string $to.  @from should be
 142     # sorted so the lowest code point is first....
 143     # The input is in string form; %tests uses code points, so have to
 144     # convert.
 145
 146     my $to_chars = length $to;
 147     my @test_to;        # List of tests for $to
 148
 149     if ($to_chars == 1) {
 150         @test_to = ord $to;
 151     }
 152     else {
 153         push @test_to, [ map { ord $_ } split "", $to ];
 154
 155         # For multi-char folds, we also test that things that can fold to each
 156         # individual character in the fold also work.  If we were testing
 157         # comprehensively, we would try every combination of upper and lower
 158         # case in the fold, but it will have to suffice to avoid running
 159         # forever to make sure that each thing that folds to these is tested
 160         # at least once.  Because of complement matching ([^...]), we need to
 161         # do both the folded, and the folded-from.
 162         # We first look at each character in the multi-char fold, and save how
 163         # many characters fold to it; and also the maximum number of such
 164         # folds
 165         my @folds_to_count;     # 0th char in fold is index 0 ...
 166         my $max_folds_to = 0;
 167
 168         for (my $i = 0; $i < $to_chars; $i++) {
 169             my $to_char = substr($to, $i, 1);
 170             if (exists $inverse_folds{$to_char}) {
 171                 $folds_to_count[$i] = scalar @{$inverse_folds{$to_char}};
 172                 $max_folds_to = $folds_to_count[$i] if $max_folds_to < $folds_to_count[$i];
 173             }
 174             else {
 175                 $folds_to_count[$i] = 0;
 176             }
 177         }
 178
 179         # We will need to generate as many tests as the maximum number of
 180         # folds, so that each fold will have at least one test.
 181         # For example, consider character X which folds to the three character
 182         # string 'xyz'.  If 2 things fold to x (X and x), 4 to y (Y, Y'
 183         # (Y-prime), Y'' (Y-prime-prime), and y), and 1 thing to z (itself), 4
 184         # tests will be generated:
 185         #   xyz
 186         #   XYz
 187         #   xY'z
 188         #   xY''z
 189         for (my $i = 0; $i < $max_folds_to; $i++) {
 190             my @this_test_to;   # Assemble a single test
 191
 192             # For each character in the multi-char fold ...
 193             for (my $j = 0; $j < $to_chars; $j++) {
 194                 my $this_char = substr($to, $j, 1);
 195
 196                 # Use its corresponding inverse fold, if available.
 197                 if ($i < $folds_to_count[$j]) {
 198                     push @this_test_to, ord $inverse_folds{$this_char}[$i];
 199                 }
 200                 else {  # Or else itself.
 201                     push @this_test_to, ord $this_char;
 202                 }
 203             }
 204
 205             # Add this test to the list
 206             push @test_to, [ @this_test_to ];
 207         }
 208
 209         # Here, have assembled all the tests for the multi-char fold.  Sort so
 210         # lowest code points are first for consistency and aesthetics in
 211         # output.  We know there are at least two characters in the fold, but
 212         # I haven't bothered to worry about sorting on an optional third
 213         # character if the first two are identical.
 214         @test_to = sort { ($a->[0] == $b->[0])
 215                            ? $a->[1] <=> $b->[1]
 216                            : $a->[0] <=> $b->[0]
 217                         } @test_to;
 218     }
 219
 220
 221     # This test is from n bytes to m bytes.  Record that so won't try to add
 222     # another test that does the same.
 223     use bytes;
 224     my $to_bytes = length $to;
 225     foreach my $from_map (@from) {
 226         $has_test_by_byte_count{length $from_map}{$to_bytes} = $to;
 227     }
 228     no bytes;
 229
 230     my $ord_smallest_from = ord shift @from;
 231     if (exists $tests{$ord_smallest_from}) {
 232         die "There are already tests for $ord_smallest_from"
 233     };
 234
 235     # Add in the fold tests,
 236     push @{$tests{$ord_smallest_from}}, @test_to;
 237
 238     # Then any remaining froms in the equivalence class.
 239     push @{$tests{$ord_smallest_from}}, map { ord $_ } @from;
 240 }
 241
 242 # Get the Unicode rules and construct inverse mappings from them
 243
 244 use Unicode::UCD;
 245 my $file="../lib/unicore/CaseFolding.txt";
 246
 247 # Use the Unicode data file if we are on an ASCII platform (which its data is
 248 # for), and it is in the modern format (starting in Unicode 3.1.0) and it is
 249 # available.  This avoids being affected by potential bugs introduced by other
 250 # layers of Perl
 251 if (ord('A') == 65
 252     && pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) ge v3.1.0
 253     && open my $fh, "<", $file)
 254 {
 255     while (<$fh>) {
 256         chomp;
 257
 258         # Lines look like (though without the initial '#')
 259         #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE
 260
 261         # Get rid of comments, ignore blank or comment-only lines
 262         my $line = $_ =~ s/ (?: \s* \# .* )? $ //rx;
 263         next unless length $line;
 264         my ($hex_from, $fold_type, @hex_folded) = split /[\s;]+/, $line;
 265
 266         next if $fold_type =~ / ^ [IT] $/x; # Perl doesn't do Turkish folding
 267         next if $fold_type eq 'S';  # If Unicode's tables are correct, the F
 268                                     # should be a superset of S
 269
 270         my $folded_str = pack ("U0U*", map { hex $_ } @hex_folded);
 271         push @{$inverse_folds{$folded_str}}, chr hex $hex_from;
 272     }
 273 }
 274 else {  # Here, can't use the .txt file: read the Unicode rules file and
 275         # construct inverse mappings from it
 276
 277     my ($invlist_ref, $invmap_ref, undef, $default)
 278                                     = Unicode::UCD::prop_invmap('Case_Folding');
 279     for my $i (0 .. @$invlist_ref - 1 - 1) {
 280         next if $invmap_ref->[$i] == $default;
 281
 282         # Make into an array if not so already, so can treat uniformly below
 283         $invmap_ref->[$i] = [ $invmap_ref->[$i] ] if ! ref $invmap_ref->[$i];
 284
 285         # Each subsequent element of the range requires adjustment of +1 from
 286         # the previous element
 287         my $adjust = -1;
 288         for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) {
 289             $adjust++;
 290             my $folded_str
 291                         = pack "U0U*", map { $_ + $adjust } @{$invmap_ref->[$i]};
 292             #note (sprintf "%d: %04X: %s", __LINE__, $j, join " ",
 293             #    map { sprintf "%04X", $_  + $adjust } @{$invmap_ref->[$i]});
 294             push @{$inverse_folds{$folded_str}}, chr $j;
 295         }
 296     }
 297 }
 298
 299 # Analyze the data and generate tests to get adequate test coverage.  We sort
 300 # things so that smallest code points are done first.
 301 TO:
 302 foreach my $to (sort { (length $a == length $b)
 303                         ? $a cmp $b
 304                         : length $a <=> length $b
 305                     } keys %inverse_folds)
 306 {
 307
 308     # Within each fold, sort so that the smallest code points are done first
 309     @{$inverse_folds{$to}} = sort { $a cmp $b } @{$inverse_folds{$to}};
 310     my @from = @{$inverse_folds{$to}};
 311
 312     # Just add it to the tests if doing complete coverage
 313     if (! $skip_apparently_redundant) {
 314         add_test($to, @from);
 315         next TO;
 316     }
 317
 318     my $to_chars = length $to;
 319     my $to_range_type = range_type(substr($to, 0, 1));
 320
 321     # If this is required to be tested, do so.  We check for these first, as
 322     # they will take up slots of byte-to-byte combinations that we otherwise
 323     # would have to have other tests to get.
 324     foreach my $from_map (@from) {
 325         if (exists $be_sure_to_test{$from_map}) {
 326             add_test($to, @from);
 327             next TO;
 328         }
 329     }
 330
 331     # If the fold contains heterogeneous range types, is suspect and should be
 332     # tested.
 333     if ($to_chars > 1) {
 334         foreach my $char (split "", $to) {
 335             if (range_type($char) != $to_range_type) {
 336                 add_test($to, @from);
 337                 next TO;
 338             }
 339         }
 340     }
 341
 342     # If the mapping crosses range types, is suspect and should be tested
 343     foreach my $from_map (@from) {
 344         if (range_type($from_map) != $to_range_type) {
 345             add_test($to, @from);
 346             next TO;
 347         }
 348     }
 349
 350     # Here, all components of the mapping are in the same range type.  For
 351     # single character folds, we test one case in each range type that has 2
 352     # particpants, 3 particpants, etc.
 353     if ($to_chars == 1) {
 354         if (! exists $has_test_by_participants{scalar @from}{$to_range_type}) {
 355             add_test($to, @from);
 356             $has_test_by_participants{scalar @from}{$to_range_type} = $to;
 357             next TO;
 358         }
 359     }
 360
 361     # We also test all combinations of mappings from m to n bytes.  This is
 362     # because the regex optimizer cares.  (Don't bother worrying about that
 363     # Latin1 chars will occupy a different number of bytes under utf8, as
 364     # there are plenty of other cases that catch these byte numbers.)
 365     use bytes;
 366     my $to_bytes = length $to;
 367     foreach my $from_map (@from) {
 368         if (! exists $has_test_by_byte_count{length $from_map}{$to_bytes}) {
 369             add_test($to, @from);
 370             next TO;
 371         }
 372     }
 373 }
 374
 375 # For each range type, test additionally a character that folds to itself
 376 add_test(chr 0x3A, chr 0x3A);
 377 add_test(chr 0xF7, chr 0xF7);
 378 add_test(chr 0x2C7, chr 0x2C7);
 379
 380 # To cut down on the number of tests
 381 my $has_tested_aa_above_latin1;
 382 my $has_tested_latin1_aa;
 383 my $has_tested_ascii_aa;
 384 my $has_tested_l_above_latin1;
 385 my $has_tested_above_latin1_l;
 386 my $has_tested_ascii_l;
 387 my $has_tested_above_latin1_d;
 388 my $has_tested_ascii_d;
 389 my $has_tested_non_latin1_d;
 390 my $has_tested_above_latin1_a;
 391 my $has_tested_ascii_a;
 392 my $has_tested_non_latin1_a;
 393
 394 # For use by pairs() in generating combinations
 395 sub prefix {
 396     my $p = shift;
 397     map [ $p, $_ ], @_
 398 }
 399
 400 # Returns all ordered combinations of pairs of elements from the input array.
 401 # It doesn't return pairs like (a, a), (b, b).  Change the slice to an array
 402 # to do that.  This was just to have fewer tests.
 403 sub pairs (@) {
 404     #print __LINE__, ": ", join(" XXX ", map { sprintf "%04X", $_ } @_), "\n";
 405     map { prefix $_[$_], @_[0..$_-1, $_+1..$#_] } 0..$#_
 406 }
 407
 408 my @charsets = qw(d u a aa);
 409 if($Config{d_setlocale}) {
 410     my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // "";
 411     if ($current_locale eq 'C') {
 412         require locale; import locale;
 413
 414         # Some implementations don't have the 128-255 range characters all
 415         # mean nothing under the C locale (an example being VMS).  This is
 416         # legal, but since we don't know what the right answers should be,
 417         # skip the locale tests in that situation.
 418         for my $i (128 .. 255) {
 419             my $char = chr($i);
 420             goto untestable_locale if uc($char) ne $char || lc($char) ne $char;
 421         }
 422         push @charsets, 'l';
 423       untestable_locale:
 424     }
 425 }
 426
 427 # Finally ready to do the tests
 428 foreach my $test (sort { numerically } keys %tests) {
 429
 430   my $previous_target;
 431   my $previous_pattern;
 432   my @pairs = pairs(sort numerically $test, @{$tests{$test}});
 433
 434   # Each fold can be viewed as a closure of all the characters that
 435   # participate in it.  Look at each possible pairing from a closure, with the
 436   # first member of the pair the target string to match against, and the
 437   # second member forming the pattern.  Thus each fold member gets tested as
 438   # the string, and the pattern with every other member in the opposite role.
 439   while (my $pair = shift @pairs) {
 440     my ($target, $pattern) = @$pair;
 441
 442     # When testing a char that doesn't fold, we can get the same
 443     # permutation twice; so skip all but the first.
 444     next if $previous_target
 445             && $previous_target == $target
 446             && $previous_pattern == $pattern;
 447     ($previous_target, $previous_pattern) = ($target, $pattern);
 448
 449     # Each side may be either a single char or a string.  Extract each into an
 450     # array (perhaps of length 1)
 451     my @target, my @pattern;
 452     @target = (ref $target) ? @$target : $target;
 453     @pattern = (ref $pattern) ? @$pattern : $pattern;
 454
 455     # We are testing just folds to/from a single character.  If our pairs
 456     # happens to generate multi/multi, skip.
 457     next if @target > 1 && @pattern > 1;
 458
 459     # Have to convert non-utf8 chars to native char set
 460     @target = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @target;
 461     @pattern = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @pattern;
 462
 463     # Get in hex form.
 464     my @x_target = map { sprintf "\\x{%04X}", $_ } @target;
 465     my @x_pattern = map { sprintf "\\x{%04X}", $_ } @pattern;
 466
 467     my $target_above_latin1 = grep { $_ > 255 } @target;
 468     my $pattern_above_latin1 = grep { $_ > 255 } @pattern;
 469     my $target_has_ascii = grep { $_ < 128 } @target;
 470     my $pattern_has_ascii = grep { $_ < 128 } @pattern;
 471     my $target_only_ascii = ! grep { $_ > 127 } @target;
 472     my $pattern_only_ascii = ! grep { $_ > 127 } @pattern;
 473     my $target_has_latin1 = grep { $_ < 256 } @target;
 474     my $target_has_upper_latin1 = grep { $_ < 256 && $_ > 127 } @target;
 475     my $pattern_has_upper_latin1 = grep { $_ < 256 && $_ > 127 } @pattern;
 476     my $pattern_has_latin1 = grep { $_ < 256 } @pattern;
 477     my $is_self = @target == 1 && @pattern == 1 && $target[0] == $pattern[0];
 478
 479     # We don't test multi-char folding into other multi-chars.  We are testing
 480     # a code point that folds to or from other characters.  Find the single
 481     # code point for diagnostic purposes.  (If both are single, choose the
 482     # target string)
 483     my $ord = @target == 1 ? $target[0] : $pattern[0];
 484     my $progress = sprintf "%04X: \"%s\" and /%s/",
 485                             $test,
 486                             join("", @x_target),
 487                             join("", @x_pattern);
 488     #note $progress;
 489
 490     # Now grind out tests, using various combinations.
 491     foreach my $charset (@charsets) {
 492       $okays = 0;
 493       $this_iteration = 0;
 494
 495       # To cut down somewhat on the enormous quantity of tests this currently
 496       # runs, skip some for some of the character sets whose results aren't
 497       # likely to differ from others.  But run all tests on the code points
 498       # that don't fold, plus one other set in each range group.
 499       if (! $is_self) {
 500
 501         # /aa should only affect things with folds in the ASCII range.  But, try
 502         # it on one set in the other ranges just to make sure it doesn't break
 503         # them.
 504         if ($charset eq 'aa') {
 505           if (! $target_has_ascii && ! $pattern_has_ascii) {
 506             if ($target_above_latin1 || $pattern_above_latin1) {
 507               next if defined $has_tested_aa_above_latin1
 508                       && $has_tested_aa_above_latin1 != $test;
 509               $has_tested_aa_above_latin1 = $test;
 510             }
 511             next if defined $has_tested_latin1_aa
 512                     && $has_tested_latin1_aa != $test;
 513             $has_tested_latin1_aa = $test;
 514           }
 515           elsif ($target_only_ascii && $pattern_only_ascii) {
 516
 517               # And, except for one set just to make sure, skip tests
 518               # where both elements in the pair are ASCII.  If one works for
 519               # aa, the others are likely too.  This skips tests where the
 520               # fold is from non-ASCII to ASCII, but this part of the test
 521               # is just about the ASCII components.
 522               next if defined $has_tested_ascii_l
 523                       && $has_tested_ascii_l != $test;
 524               $has_tested_ascii_l = $test;
 525           }
 526         }
 527         elsif ($charset eq 'l') {
 528
 529           # For l, don't need to test beyond one set those things that are
 530           # all above latin1, because unlikely to have different successes
 531           # than /u
 532           if (! $target_has_latin1 && ! $pattern_has_latin1) {
 533             next if defined $has_tested_above_latin1_l
 534                     && $has_tested_above_latin1_l != $test;
 535             $has_tested_above_latin1_l = $test;
 536           }
 537           elsif ($target_only_ascii && $pattern_only_ascii) {
 538
 539               # And, except for one set just to make sure, skip tests
 540               # where both elements in the pair are ASCII.  This is
 541               # essentially the same reasoning as above for /aa.
 542               next if defined $has_tested_ascii_l
 543                       && $has_tested_ascii_l != $test;
 544               $has_tested_ascii_l = $test;
 545           }
 546         }
 547         elsif ($charset eq 'd') {
 548           # Similarly for d.  Beyond one test (besides self) each, we  don't
 549           # test pairs that are both ascii; or both above latin1, or are
 550           # combinations of ascii and above latin1.
 551           if (! $target_has_upper_latin1 && ! $pattern_has_upper_latin1) {
 552             if ($target_has_ascii && $pattern_has_ascii) {
 553               next if defined $has_tested_ascii_d
 554                       && $has_tested_ascii_d != $test;
 555               $has_tested_ascii_d = $test
 556             }
 557             elsif (! $target_has_latin1 && ! $pattern_has_latin1) {
 558               next if defined $has_tested_above_latin1_d
 559                       && $has_tested_above_latin1_d != $test;
 560               $has_tested_above_latin1_d = $test;
 561             }
 562             else {
 563               next if defined $has_tested_non_latin1_d
 564                       && $has_tested_non_latin1_d != $test;
 565               $has_tested_non_latin1_d = $test;
 566             }
 567           }
 568         }
 569         elsif ($charset eq 'a') {
 570           # Similarly for a.  This should match identically to /u, so wasn't
 571           # tested at all until a bug was found that was thereby missed.
 572           # As a compromise, beyond one test (besides self) each, we  don't
 573           # test pairs that are both ascii; or both above latin1, or are
 574           # combinations of ascii and above latin1.
 575           if (! $target_has_upper_latin1 && ! $pattern_has_upper_latin1) {
 576             if ($target_has_ascii && $pattern_has_ascii) {
 577               next if defined $has_tested_ascii_a
 578                       && $has_tested_ascii_a != $test;
 579               $has_tested_ascii_a = $test
 580             }
 581             elsif (! $target_has_latin1 && ! $pattern_has_latin1) {
 582               next if defined $has_tested_above_latin1_a
 583                       && $has_tested_above_latin1_a != $test;
 584               $has_tested_above_latin1_a = $test;
 585             }
 586             else {
 587               next if defined $has_tested_non_latin1_a
 588                       && $has_tested_non_latin1_a != $test;
 589               $has_tested_non_latin1_a = $test;
 590             }
 591           }
 592         }
 593       }
 594
 595       foreach my $utf8_target (0, 1) {    # Both utf8 and not, for
 596                                           # code points < 256
 597         my $upgrade_target = "";
 598
 599         # These must already be in utf8 because the string to match has
 600         # something above latin1.  So impossible to test if to not to be in
 601         # utf8; and otherwise, no upgrade is needed.
 602         next if $target_above_latin1 && ! $utf8_target;
 603         $upgrade_target = ' utf8::upgrade($c);' if ! $target_above_latin1 && $utf8_target;
 604
 605         foreach my $utf8_pattern (0, 1) {
 606           next if $pattern_above_latin1 && ! $utf8_pattern;
 607
 608           # Our testing of 'l' uses the POSIX locale, which is ASCII-only
 609           my $uni_semantics = $charset ne 'l' && ($utf8_target || $charset eq 'u' || ($charset eq 'd' && $utf8_pattern) || $charset =~ /a/);
 610           my $upgrade_pattern = "";
 611           $upgrade_pattern = ' utf8::upgrade($p);' if ! $pattern_above_latin1 && $utf8_pattern;
 612
 613           my $lhs = join "", @x_target;
 614           my $lhs_str = eval qq{"$lhs"}; fail($@) if $@;
 615           my @rhs = @x_pattern;
 616           my $rhs = join "", @rhs;
 617           my $should_fail = (! $uni_semantics && $ord >= 128 && $ord < 256 && ! $is_self)
 618                             || ($charset eq 'aa' && $target_has_ascii != $pattern_has_ascii)
 619                             || ($charset eq 'l' && $target_has_latin1 != $pattern_has_latin1);
 620
 621           # Do simple tests of referencing capture buffers, named and
 622           # numbered.
 623           my $op = '=~';
 624           $op = '!~' if $should_fail;
 625
 626           my $todo = 0;  # No longer any todo's
 627           my $eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
 628           run_test($eval, $todo, "");
 629
 630           $eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^(?<grind>$rhs)\\k<grind>\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
 631           run_test($eval, $todo, "");
 632
 633           if ($lhs ne $rhs) {
 634             $eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
 635             run_test($eval, "", "");
 636
 637             $eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^(?<grind>$rhs)\\k<grind>\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
 638             run_test($eval, "", "");
 639           }
 640
 641           # See if works on what could be a simple trie.
 642           $eval = "my \$c = \"$lhs\"; my \$p = qr/$rhs|xyz/i$charset;$upgrade_target$upgrade_pattern \$c $op \$p";
 643           run_test($eval, "", "");
 644
 645           # Check that works when the folded character follows something that
 646           # is quantified.  This test knows the regex code internals to the
 647           # extent that it knows this is a potential problem, and that there
 648           # are three different types of quantifiers generated: 1) The thing
 649           # being quantified matches a single character; 2) it matches more
 650           # than one character, but is fixed width; 3) it can match a variable
 651           # number of characters.  (It doesn't know that case 3 shouldn't
 652           # matter, since it doesn't do anything special for the character
 653           # following the quantifier; nor that some of the different
 654           # quantifiers execute the same underlying code, as these tests are
 655           # quick, and this insulates these tests from changes in the
 656           # implementation.)
 657           for my $quantifier ('?', '??', '*', '*?', '+', '+?', '{1,2}', '{1,2}?') {
 658             $eval = "my \$c = \"_$lhs\"; my \$p = qr/(?$charset:.$quantifier$rhs)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
 659             run_test($eval, "", "");
 660             $eval = "my \$c = \"__$lhs\"; my \$p = qr/(?$charset:(?:..)$quantifier$rhs)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
 661             run_test($eval, "", "");
 662             $eval = "my \$c = \"__$lhs\"; my \$p = qr/(?$charset:(?:.|\\R)$quantifier$rhs)/i;$upgrade_target$upgrade_pattern \$c $op \$p";
 663             run_test($eval, "", "");
 664           }
 665
 666           foreach my $bracketed (0, 1) {   # Put rhs in [...], or not
 667             next if $bracketed && @pattern != 1;    # bracketed makes these
 668                                                     # or's instead of a sequence
 669             foreach my $optimize_bracketed (0, 1) {
 670                 next if $optimize_bracketed && ! $bracketed;
 671             foreach my $inverted (0,1) {
 672                 next if $inverted && ! $bracketed;  # inversion only valid in [^...]
 673                 next if $inverted && @target != 1;  # [perl #89750] multi-char
 674                                                     # not valid in [^...]
 675
 676               # In some cases, add an extra character that doesn't fold, and
 677               # looks ok in the output.
 678               my $extra_char = "_";
 679               foreach my $prepend ("", $extra_char) {
 680                 foreach my $append ("", $extra_char) {
 681
 682                   # Assemble the rhs.  Put each character in a separate
 683                   # bracketed if using charclasses.  This creates a stress on
 684                   # the code to span a match across multiple elements
 685                   my $rhs = "";
 686                   foreach my $rhs_char (@rhs) {
 687                       $rhs .= '[' if $bracketed;
 688                       $rhs .= '^' if $inverted;
 689                       $rhs .=  $rhs_char;
 690
 691                       # Add a character to the class, so class doesn't get
 692                       # optimized out, unless we are testing that optimization
 693                       $rhs .= '_' if $optimize_bracketed;
 694                       $rhs .= ']' if $bracketed;
 695                   }
 696
 697                   # Add one of: no capturing parens
 698                   #             a single set
 699                   #             a nested set
 700                   # Use quantifiers and extra variable width matches inside
 701                   # them to keep some optimizations from happening
 702                   foreach my $parend (0, 1, 2) {
 703                     my $interior = (! $parend)
 704                                     ? $rhs
 705                                     : ($parend == 1)
 706                                         ? "(${rhs},?)"
 707                                         : "((${rhs})+,?)";
 708                     foreach my $quantifier ("", '?', '*', '+', '{1,3}') {
 709
 710                       # Perhaps should be TODOs, as are unimplemented, but
 711                       # maybe will never be implemented
 712                       next if @pattern != 1 && $quantifier;
 713
 714                       # A ? or * quantifier normally causes the thing to be
 715                       # able to match a null string
 716                       my $quantifier_can_match_null = $quantifier eq '?' || $quantifier eq '*';
 717
 718                       # But since we only quantify the last character in a
 719                       # multiple fold, the other characters will have width,
 720                       # except if we are quantifying the whole rhs
 721                       my $can_match_null = $quantifier_can_match_null && (@rhs == 1 || $parend);
 722
 723                       foreach my $l_anchor ("", '^') { # '\A' didn't change result)
 724                         foreach my $r_anchor ("", '$') { # '\Z', '\z' didn't change result)
 725
 726                           # The folded part can match the null string if it
 727                           # isn't required to have width, and there's not
 728                           # something on one or both sides that force it to.
 729                           my $both_sides = ($l_anchor && $r_anchor) || ($l_anchor && $append) || ($r_anchor && $prepend) || ($prepend && $append);
 730                           my $must_match = ! $can_match_null || $both_sides;
 731                           # for performance, but doing this missed many failures
 732                           #next unless $must_match;
 733                           my $quantified = "(?$charset:$l_anchor$prepend$interior${quantifier}$append$r_anchor)";
 734                           my $op;
 735                           if ($must_match && $should_fail)  {
 736                               $op = 0;
 737                           } else {
 738                               $op = 1;
 739                           }
 740                           $op = ! $op if $must_match && $inverted;
 741
 742                           if ($inverted && @target > 1) {
 743                             # When doing an inverted match against a
 744                             # multi-char target, and there is not something on
 745                             # the left to anchor the match, if it shouldn't
 746                             # succeed, skip, as what will happen (when working
 747                             # correctly) is that it will match the first
 748                             # position correctly, and then be inverted to not
 749                             # match; then it will go to the second position
 750                             # where it won't match, but get inverted to match,
 751                             # and hence succeeding.
 752                             next if ! ($l_anchor || $prepend) && ! $op;
 753
 754                             # Can't ever match for latin1 code points non-uni
 755                             # semantics that have a inverted multi-char fold
 756                             # when there is something on both sides and the
 757                             # quantifier isn't such as to span the required
 758                             # width, which is 2 or 3.
 759                             $op = 0 if $ord < 255
 760                                        && ! $uni_semantics
 761                                        && $both_sides
 762                                        && ( ! $quantifier || $quantifier eq '?')
 763                                        && $parend < 2;
 764
 765                             # Similarly can't ever match when inverting a multi-char
 766                             # fold for /aa and the quantifier isn't sufficient
 767                             # to allow it to span to both sides.
 768                             $op = 0 if $target_has_ascii && $charset eq 'aa' && $both_sides && ( ! $quantifier || $quantifier eq '?') && $parend < 2;
 769
 770                             # Or for /l
 771                             $op = 0 if $target_has_latin1 && $charset eq 'l' && $both_sides && ( ! $quantifier || $quantifier eq '?') && $parend < 2;
 772                           }
 773
 774
 775                           my $desc = "my \$c = \"$prepend$lhs$append\"; "
 776                                    . "my \$p = qr/$quantified/i;"
 777                                    . "$upgrade_target$upgrade_pattern "
 778                                    . "\$c " . ($op ? "=~" : "!~") . " \$p; ";
 779                           if ($DEBUG) {
 780                             $desc .= (
 781                              "; uni_semantics=$uni_semantics, "
 782                              . "should_fail=$should_fail, "
 783                              . "bracketed=$bracketed, "
 784                              . "prepend=$prepend, "
 785                              . "append=$append, "
 786                              . "parend=$parend, "
 787                              . "quantifier=$quantifier, "
 788                              . "l_anchor=$l_anchor, "
 789                              . "r_anchor=$r_anchor; "
 790                              . "pattern_above_latin1=$pattern_above_latin1; "
 791                              . "utf8_pattern=$utf8_pattern"
 792                             );
 793                           }
 794
 795                           my $c = "$prepend$lhs_str$append";
 796                           my $p = qr/$quantified/i;
 797                           utf8::upgrade($c) if length($upgrade_target);
 798                           utf8::upgrade($p) if length($upgrade_pattern);
 799                           my $res = $op ? ($c =~ $p): ($c !~ $p);
 800
 801                           if (!$res || $list_all_tests) {
 802                             # Failed or debug; output the result
 803                             $count++;
 804                             ok($res, "test $count - $desc");
 805                           } else {
 806                             # Just count the test as passed
 807                             $okays++;
 808                           }
 809                           $this_iteration++;
 810                         }
 811                       }
 812                     }
 813                   }
 814                 }
 815               }
 816             }
 817           }
 818           }
 819         }
 820       }
 821       unless($list_all_tests) {
 822         $count++;
 823         is $okays, $this_iteration, "$okays subtests ok for"
 824           . " /$charset,"
 825           . ' target="' . join("", @x_target) . '",'
 826           . ' pat="' . join("", @x_pattern) . '"';
 827       }
 828     }
 829   }
 830 }
 831
 832 plan($count);
 833
 834 1