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