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