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