Commit | Line | Data |
---|---|---|
371a505e | 1 | # Grind out a lot of combinatoric tests for folding. |
a2d9a01a KW |
2 | |
3 | use charnames ":full"; | |
4 | ||
5 | binmode STDOUT, ":utf8"; | |
6 | ||
7 | BEGIN { | |
8 | chdir 't' if -d 't'; | |
9 | @INC = '../lib'; | |
10 | require './test.pl'; | |
c82d0e1e | 11 | skip_all_if_miniperl("no dynamic loading on miniperl, no Encode"); |
a2d9a01a KW |
12 | } |
13 | ||
29d01a3e | 14 | my $DEBUG = 0; # Outputs extra information for debugging this .t |
abf4d645 | 15 | |
a2d9a01a KW |
16 | use strict; |
17 | use warnings; | |
d08723ac | 18 | use Encode; |
a2d9a01a KW |
19 | |
20 | # Tests both unicode and not, so make sure not implicitly testing unicode | |
21 | no feature 'unicode_strings'; | |
22 | ||
23 | # Case-insensitive matching is a large and complicated issue. Perl does not | |
24 | # implement it fully, properly. For example, it doesn't include normalization | |
25 | # as part of the equation. To test every conceivable combination is clearly | |
26 | # impossible; these tests are mostly drawn from visual inspection of the code | |
27 | # and experience, trying to exercise all areas. | |
28 | ||
29 | # There are three basic ranges of characters that Perl may treat differently: | |
30 | # 1) Invariants under utf8 which on ASCII-ish machines are ASCII, and are | |
31 | # referred to here as ASCII. On EBCDIC machines, the non-ASCII invariants | |
32 | # are all controls that fold to themselves. | |
33 | my $ASCII = 1; | |
34 | ||
35 | # 2) Other characters that fit into a byte but are different in utf8 than not; | |
36 | # here referred to, taking some liberties, as Latin1. | |
37 | my $Latin1 = 2; | |
38 | ||
39 | # 3) Characters that won't fit in a byte; here referred to as Unicode | |
40 | my $Unicode = 3; | |
41 | ||
42 | # Within these basic groups are equivalence classes that testing any character | |
43 | # in is likely to lead to the same results as any other character. This is | |
44 | # used to cut down the number of tests needed, unless PERL_RUN_SLOW_TESTS is | |
45 | # set. | |
46 | my $skip_apparently_redundant = ! $ENV{PERL_RUN_SLOW_TESTS}; | |
47 | ||
48 | sub range_type { | |
49 | my $ord = shift; | |
50 | ||
51 | return $ASCII if $ord < 128; | |
52 | return $Latin1 if $ord < 256; | |
53 | return $Unicode; | |
54 | } | |
55 | ||
17580e7a | 56 | my %todos; # List of test numbers that are expected to fail |
abf4d645 | 57 | map { $todos{$_} = '1' } ( |
27f6057f KW |
58 | 127405, |
59 | 127406, | |
60 | 127425, | |
61 | 127426, | |
62 | 127437, | |
63 | 127438, | |
64 | 127469, | |
65 | 127470, | |
66 | 127489, | |
67 | 127490, | |
68 | 127501, | |
69 | 127502, | |
abf4d645 KW |
70 | ); |
71 | ||
a2d9a01a KW |
72 | sub numerically { |
73 | return $a <=> $b | |
74 | } | |
75 | ||
abf4d645 KW |
76 | sub format_test($$$) { |
77 | my ($test, $count, $debug) = @_; | |
78 | ||
29d01a3e KW |
79 | # Create a test entry, with TODO set if it is one of the known problem |
80 | # code points | |
81 | ||
abf4d645 KW |
82 | $debug = "" unless $DEBUG; |
83 | ||
84 | my $todo = (exists $todos{$count}) ? "Known problem" : 0; | |
85 | ||
86 | return qq[TODO: { local \$::TODO = "$todo"; ok(eval '$test', '$test; $debug'); }]; | |
87 | } | |
88 | ||
29d01a3e | 89 | my %tests; # The final set of tests. keys are the code points to test |
a2d9a01a KW |
90 | my %simple_folds; |
91 | my %multi_folds; | |
92 | ||
93 | # First, analyze the current Unicode's folding rules | |
94 | my %folded_from; | |
95 | my $file="../lib/unicore/CaseFolding.txt"; | |
96 | open my $fh, "<", $file or die "Failed to read '$file': $!"; | |
97 | while (<$fh>) { | |
98 | chomp; | |
99 | ||
100 | # Lines look like (though without the initial '#') | |
101 | #0130; F; 0069 0307; # LATIN CAPITAL LETTER I WITH DOT ABOVE | |
102 | ||
103 | my ($line, $comment) = split / \s+ \# \s+ /x, $_; | |
104 | next if $line eq "" || substr($line, 0, 1) eq '#'; | |
105 | my ($hex_from, $fold_type, @folded) = split /[\s;]+/, $line; | |
106 | ||
107 | my $from = hex $hex_from; | |
108 | ||
109 | if ($fold_type eq 'F') { | |
27f6057f KW |
110 | my $from_range_type = range_type($from); |
111 | ||
112 | # If we were testing comprehensively, we would try every combination | |
113 | # of upper and lower case in the fold, but it is quite likely that if | |
114 | # the code can handle all combinations if it can handle the cases | |
115 | # where everything is upper and when everything is lower. Because of | |
116 | # complement matching, we need to do both. And we use the | |
117 | # reverse-fold instead of uppercase. | |
a2d9a01a | 118 | @folded = map { hex $_ } @folded; |
27f6057f KW |
119 | # XXX better to use reverse fold of these instead of uc |
120 | my @uc_folded = map { ord uc chr $_ } @folded; | |
a2d9a01a KW |
121 | |
122 | # Include three code points that are handled internally by the regex | |
29d01a3e | 123 | # engine specially, plus all non-above-255 multi folds (which actually |
a2d9a01a KW |
124 | # the only one is already included in the three, but this makes sure) |
125 | # And if any member of the fold is not the same range type as the | |
126 | # source, add it directly to the tests. It needs to be an array of an | |
127 | # array, so that it is distinguished from multiple single folds | |
128 | if ($from == 0xDF || $from == 0x390 || $from == 0x3B0 | |
129 | || $from_range_type != $Unicode | |
130 | || grep { range_type($_) != $from_range_type } @folded) | |
131 | { | |
27f6057f | 132 | $tests{$from} = [ [ @folded ], [ @uc_folded ] ]; |
a2d9a01a KW |
133 | } |
134 | else { | |
135 | ||
27f6057f KW |
136 | # The only multi-char non-utf8 fold is DF, which is handled above, |
137 | # so here chr() must be utf8. Get the number of bytes in each. | |
138 | # This is because the optimizer cares about length differences. | |
139 | my $from_length = length encode('UTF-8', chr($from)); | |
140 | my $to_length = length encode('UTF-8', pack 'U*', @folded); | |
141 | push @{$multi_folds{$from_length}{$to_length}}, { $from => [ [ @folded ], [ @uc_folded ] ] }; | |
a2d9a01a KW |
142 | } |
143 | } | |
144 | ||
145 | # Perl only deals with C and F folds | |
146 | next if $fold_type ne 'C'; | |
147 | ||
d2025f57 KW |
148 | # C folds are single-char $from to single-char $folded, in chr terms |
149 | # folded_from{'s'} = [ 'S', \N{LATIN SMALL LETTER LONG S} ] | |
a2d9a01a KW |
150 | push @{$folded_from{hex $folded[0]}}, $from; |
151 | } | |
152 | ||
d2025f57 | 153 | # Now try to sort the single char folds into equivalence classes that are |
a2d9a01a KW |
154 | # likely to have identical successes and failures. Any fold that crosses |
155 | # range types is suspect, and is automatically tested. Otherwise, store by | |
156 | # the number of characters that participate in a fold. Likely all folds in a | |
157 | # range type that fold to each other like B->b->B will have identical success | |
158 | # and failure; similarly all folds that have three characters participating | |
159 | # are likely to have the same successes and failures, etc. | |
160 | foreach my $folded (sort numerically keys %folded_from) { | |
161 | my $target_range_type = range_type($folded); | |
162 | my $count = @{$folded_from{$folded}}; | |
163 | ||
164 | # Automatically test any fold that crosses range types | |
165 | if (grep { range_type($_) != $target_range_type } @{$folded_from{$folded}}) | |
166 | { | |
167 | $tests{$folded} = $folded_from{$folded}; | |
168 | } | |
169 | else { | |
170 | push @{$simple_folds{$target_range_type}{$count}}, | |
171 | { $folded => $folded_from{$folded} }; | |
a7caa9e8 | 172 | } |
a2d9a01a KW |
173 | } |
174 | ||
175 | foreach my $from_length (keys %multi_folds) { | |
176 | foreach my $fold_length (keys %{$multi_folds{$from_length}}) { | |
177 | #print __LINE__, ref $multi_folds{$from_length}{$fold_length}, Dumper $multi_folds{$from_length}{$fold_length}; | |
178 | foreach my $test (@{$multi_folds{$from_length}{$fold_length}}) { | |
179 | #print __LINE__, ": $from_length, $fold_length, $test:\n"; | |
180 | my ($target, $pattern) = each %$test; | |
181 | #print __LINE__, ": $target: $pattern\n"; | |
182 | $tests{$target} = $pattern; | |
183 | last if $skip_apparently_redundant; | |
184 | } | |
185 | } | |
186 | } | |
187 | ||
188 | # Add in tests for single character folds. Add tests for each range type, | |
189 | # and within those tests for each number of characters participating in a | |
190 | # fold. Thus B->b has two characters participating. But K->k and Kelvin | |
191 | # Sign->k has three characters participating. So we would make sure that | |
192 | # there is a test for 3 chars, 4 chars, ... . (Note that the 'k' example is a | |
193 | # bad one because it crosses range types, so is automatically tested. In the | |
194 | # Unicode range there are various of these 3 and 4 char classes, but aren't as | |
195 | # easily described as the 'k' one.) | |
196 | foreach my $type (keys %simple_folds) { | |
197 | foreach my $count (keys %{$simple_folds{$type}}) { | |
198 | foreach my $test (@{$simple_folds{$type}{$count}}) { | |
199 | my ($target, $pattern) = each %$test; | |
200 | $tests{$target} = $pattern; | |
201 | last if $skip_apparently_redundant; | |
202 | } | |
203 | } | |
204 | } | |
205 | ||
206 | # For each range type, test additionally a character that folds to itself | |
207 | $tests{0x3A} = [ 0x3A ]; | |
208 | $tests{0xF7} = [ 0xF7 ]; | |
209 | $tests{0x2C7} = [ 0x2C7 ]; | |
210 | ||
29069c2e | 211 | my $clump_execs = 1000; # Speed up by building an 'exec' of many tests |
a2d9a01a KW |
212 | my @eval_tests; |
213 | ||
2f7f8cb1 KW |
214 | # To cut down on the number of tests |
215 | my $has_tested_aa_above_latin1; | |
216 | my $has_tested_latin1_aa; | |
17580e7a KW |
217 | my $has_tested_l_above_latin1; |
218 | my $has_tested_latin1_l; | |
2f7f8cb1 | 219 | |
a2d9a01a KW |
220 | # For use by pairs() in generating combinations |
221 | sub prefix { | |
222 | my $p = shift; | |
a7caa9e8 | 223 | map [ $p, $_ ], @_ |
a2d9a01a KW |
224 | } |
225 | ||
226 | # Returns all ordered combinations of pairs of elements from the input array. | |
227 | # It doesn't return pairs like (a, a), (b, b). Change the slice to an array | |
228 | # to do that. This was just to have fewer tests. | |
a7caa9e8 | 229 | sub pairs (@) { |
a2d9a01a | 230 | #print __LINE__, ": ", join(" XXX ", @_), "\n"; |
a7caa9e8 | 231 | map { prefix $_[$_], @_[0..$_-1, $_+1..$#_] } 0..$#_ |
a2d9a01a KW |
232 | } |
233 | ||
234 | ||
235 | # Finally ready to do the tests | |
abf4d645 | 236 | my $count=0; |
a2d9a01a KW |
237 | foreach my $test (sort { numerically } keys %tests) { |
238 | ||
239 | my $previous_target; | |
240 | my $previous_pattern; | |
241 | my @pairs = pairs(sort numerically $test, @{$tests{$test}}); | |
242 | ||
243 | # Each fold can be viewed as a closure of all the characters that | |
244 | # participate in it. Look at each possible pairing from a closure, with the | |
245 | # first member of the pair the target string to match against, and the | |
246 | # second member forming the pattern. Thus each fold member gets tested as | |
247 | # the string, and the pattern with every other member in the opposite role. | |
248 | while (my $pair = shift @pairs) { | |
249 | my ($target, $pattern) = @$pair; | |
250 | ||
251 | # When testing a char that doesn't fold, we can get the same | |
252 | # permutation twice; so skip all but the first. | |
253 | next if $previous_target | |
254 | && $previous_target == $target | |
255 | && $previous_pattern == $pattern; | |
256 | ($previous_target, $previous_pattern) = ($target, $pattern); | |
257 | ||
258 | # Each side may be either a single char or a string. Extract each into an | |
259 | # array (perhaps of length 1) | |
260 | my @target, my @pattern; | |
261 | @target = (ref $target) ? @$target : $target; | |
262 | @pattern = (ref $pattern) ? @$pattern : $pattern; | |
263 | ||
264 | # Have to convert non-utf8 chars to native char set | |
265 | @target = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @target; | |
266 | @pattern = map { $_ > 255 ? $_ : ord latin1_to_native(chr($_)) } @pattern; | |
267 | ||
268 | # Get in hex form. | |
269 | my @x_target = map { sprintf "\\x{%04X}", $_ } @target; | |
270 | my @x_pattern = map { sprintf "\\x{%04X}", $_ } @pattern; | |
271 | ||
272 | my $target_above_latin1 = grep { $_ > 255 } @target; | |
273 | my $pattern_above_latin1 = grep { $_ > 255 } @pattern; | |
2f7f8cb1 KW |
274 | my $target_has_ascii = grep { $_ < 128 } @target; |
275 | my $pattern_has_ascii = grep { $_ < 128 } @pattern; | |
17580e7a KW |
276 | my $target_has_latin1 = grep { $_ < 256 } @target; |
277 | my $pattern_has_latin1 = grep { $_ < 256 } @pattern; | |
a2d9a01a KW |
278 | my $is_self = @target == 1 && @pattern == 1 && $target[0] == $pattern[0]; |
279 | ||
280 | # We don't test multi-char folding into other multi-chars. We are testing | |
281 | # a code point that folds to or from other characters. Find the single | |
282 | # code point for diagnostic purposes. (If both are single, choose the | |
283 | # target string) | |
284 | my $ord = @target == 1 ? $target[0] : $pattern[0]; | |
7fea222d KW |
285 | my $progress = sprintf "%04X: \"%s\" and /%s/", |
286 | $test, | |
a2d9a01a KW |
287 | join("", @x_target), |
288 | join("", @x_pattern); | |
289 | #print $progress, "\n"; | |
290 | #diag $progress; | |
291 | ||
292 | # Now grind out tests, using various combinations. | |
17580e7a | 293 | foreach my $charset ('d', 'l', 'u', 'aa') { |
2f7f8cb1 KW |
294 | |
295 | # /aa should only affect things with folds in the ASCII range. But, try | |
296 | # it on one pair in the other ranges just to make sure it doesn't break | |
297 | # them. Set these flags. They are set to the ord of the character | |
298 | # tested so that all pairs of that ord get tested. | |
299 | if ($charset eq 'aa') { | |
300 | if (! $target_has_ascii && ! $pattern_has_ascii) { | |
301 | if ($target_above_latin1 || $pattern_above_latin1) { | |
302 | next if defined $has_tested_aa_above_latin1 | |
41ce0a5e KW |
303 | && $has_tested_aa_above_latin1 != $test; |
304 | $has_tested_aa_above_latin1 = $test; | |
2f7f8cb1 | 305 | } |
41ce0a5e KW |
306 | next if defined $has_tested_latin1_aa && $has_tested_latin1_aa != $test; |
307 | $has_tested_latin1_aa = $test; | |
2f7f8cb1 KW |
308 | } |
309 | } | |
17580e7a KW |
310 | elsif ($charset eq 'l') { |
311 | if (! $target_has_latin1 && ! $pattern_has_latin1) { | |
312 | next if defined $has_tested_latin1_l && $has_tested_latin1_l != $test; | |
313 | $has_tested_latin1_l = $test; | |
314 | } | |
315 | } | |
2f7f8cb1 | 316 | |
a2d9a01a KW |
317 | foreach my $utf8_target (0, 1) { # Both utf8 and not, for |
318 | # code points < 256 | |
319 | my $upgrade_target = ""; | |
320 | ||
321 | # These must already be in utf8 because the string to match has | |
322 | # something above latin1. So impossible to test if to not to be in | |
323 | # utf8; and otherwise, no upgrade is needed. | |
324 | next if $target_above_latin1 && ! $utf8_target; | |
d08723ac | 325 | $upgrade_target = ' utf8::upgrade($c);' if ! $target_above_latin1 && $utf8_target; |
a2d9a01a | 326 | |
d08723ac KW |
327 | foreach my $utf8_pattern (0, 1) { |
328 | next if $pattern_above_latin1 && ! $utf8_pattern; | |
17580e7a KW |
329 | |
330 | # Our testing of 'l' uses the POSIX locale, which is ASCII-only | |
331 | my $uni_semantics = $charset ne 'l' && ($utf8_target || $charset eq 'u' || ($charset eq 'd' && $utf8_pattern) || $charset =~ /a/); | |
a2d9a01a | 332 | my $upgrade_pattern = ""; |
d08723ac | 333 | $upgrade_pattern = ' utf8::upgrade($p);' if ! $pattern_above_latin1 && $utf8_pattern; |
a2d9a01a KW |
334 | |
335 | my $lhs = join "", @x_target; | |
336 | my @rhs = @x_pattern; | |
371a505e | 337 | my $rhs = join "", @rhs; |
2f7f8cb1 | 338 | my $should_fail = (! $uni_semantics && $ord >= 128 && $ord < 256 && ! $is_self) |
17580e7a KW |
339 | || ($charset eq 'aa' && $target_has_ascii != $pattern_has_ascii) |
340 | || ($charset eq 'l' && $target_has_latin1 != $pattern_has_latin1); | |
371a505e KW |
341 | |
342 | # Do simple tests of referencing capture buffers, named and | |
343 | # numbered. | |
344 | my $op = '=~'; | |
345 | $op = '!~' if $should_fail; | |
d2025f57 | 346 | |
371a505e | 347 | my $eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; |
abf4d645 KW |
348 | push @eval_tests, format_test($eval, ++$count, ""); |
349 | ||
371a505e | 350 | $eval = "my \$c = \"$lhs$rhs\"; my \$p = qr/(?$charset:^(?<grind>$rhs)\\k<grind>\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; |
abf4d645 KW |
351 | push @eval_tests, format_test($eval, ++$count, ""); |
352 | ||
371a505e KW |
353 | if ($lhs ne $rhs) { |
354 | $eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^($rhs)\\1\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; | |
abf4d645 KW |
355 | push @eval_tests, format_test($eval, ++$count, ""); |
356 | ||
371a505e | 357 | $eval = "my \$c = \"$rhs$lhs\"; my \$p = qr/(?$charset:^(?<grind>$rhs)\\k<grind>\$)/i;$upgrade_target$upgrade_pattern \$c $op \$p"; |
abf4d645 | 358 | push @eval_tests, format_test($eval, ++$count, ""); |
371a505e | 359 | } |
371a505e | 360 | |
1ef17b72 | 361 | foreach my $bracketed (0, 1) { # Put rhs in [...], or not |
a2d9a01a | 362 | foreach my $inverted (0,1) { |
d2025f57 | 363 | next if $inverted && ! $bracketed; # inversion only valid in [^...] |
a2d9a01a KW |
364 | |
365 | # In some cases, add an extra character that doesn't fold, and | |
366 | # looks ok in the output. | |
367 | my $extra_char = "_"; | |
368 | foreach my $prepend ("", $extra_char) { | |
369 | foreach my $append ("", $extra_char) { | |
a2d9a01a KW |
370 | |
371 | # Assemble the rhs. Put each character in a separate | |
372 | # bracketed if using charclasses. This creates a stress on | |
373 | # the code to span a match across multiple elements | |
374 | my $rhs = ""; | |
375 | foreach my $rhs_char (@rhs) { | |
376 | $rhs .= '[' if $bracketed; | |
377 | $rhs .= '^' if $inverted; | |
378 | $rhs .= $rhs_char; | |
379 | ||
380 | # Add a character to the class, so class doesn't get | |
381 | # optimized out | |
382 | $rhs .= '_]' if $bracketed; | |
383 | } | |
384 | ||
385 | # Add one of: no capturing parens | |
386 | # a single set | |
387 | # a nested set | |
388 | # Use quantifiers and extra variable width matches inside | |
389 | # them to keep some optimizations from happening | |
390 | foreach my $parend (0, 1, 2) { | |
391 | my $interior = (! $parend) | |
392 | ? $rhs | |
393 | : ($parend == 1) | |
394 | ? "(${rhs},?)" | |
395 | : "((${rhs})+,?)"; | |
396 | foreach my $quantifier ("", '?', '*', '+', '{1,3}') { | |
397 | ||
398 | # A ? or * quantifier normally causes the thing to be | |
399 | # able to match a null string | |
400 | my $quantifier_can_match_null = $quantifier eq '?' || $quantifier eq '*'; | |
401 | ||
402 | # But since we only quantify the last character in a | |
403 | # multiple fold, the other characters will have width, | |
404 | # except if we are quantifying the whole rhs | |
405 | my $can_match_null = $quantifier_can_match_null && (@rhs == 1 || $parend); | |
406 | ||
407 | foreach my $l_anchor ("", '^') { # '\A' didn't change result) | |
408 | foreach my $r_anchor ("", '$') { # '\Z', '\z' didn't change result) | |
409 | ||
410 | # The folded part can match the null string if it | |
411 | # isn't required to have width, and there's not | |
412 | # something on one or both sides that force it to. | |
2f7f8cb1 KW |
413 | my $both_sides = ($l_anchor && $r_anchor) || ($l_anchor && $append) || ($r_anchor && $prepend) || ($prepend && $append); |
414 | my $must_match = ! $can_match_null || $both_sides; | |
415 | # for performance, but doing this missed many failures | |
a2d9a01a | 416 | #next unless $must_match; |
d08723ac | 417 | my $quantified = "(?$charset:$l_anchor$prepend$interior${quantifier}$append$r_anchor)"; |
a2d9a01a | 418 | my $op; |
d08723ac | 419 | if ($must_match && $should_fail) { |
a2d9a01a KW |
420 | $op = 0; |
421 | } else { | |
422 | $op = 1; | |
423 | } | |
424 | $op = ! $op if $must_match && $inverted; | |
27f6057f KW |
425 | |
426 | if ($inverted && @target > 1) { | |
427 | # When doing an inverted match against a | |
428 | # multi-char target, and there is not something on | |
429 | # the left to anchor the match, if it shouldn't | |
430 | # succeed, skip, as what will happen (when working | |
431 | # correctly) is that it will match the first | |
432 | # position correctly, and then be inverted to not | |
433 | # match; then it will go to the second position | |
434 | # where it won't match, but get inverted to match, | |
435 | # and hence succeeding. | |
436 | next if ! ($l_anchor || $prepend) && ! $op; | |
437 | ||
438 | # Can't ever match for latin1 code points non-uni | |
439 | # semantics that have a inverted multi-char fold | |
440 | # when there is something on both sides and the | |
441 | # quantifier isn't such as to span the required | |
442 | # width, which is 2 or 3. | |
443 | $op = 0 if $ord < 255 | |
444 | && ! $uni_semantics | |
445 | && $both_sides | |
446 | && ( ! $quantifier || $quantifier eq '?') | |
447 | && $parend < 2; | |
448 | ||
449 | # Similarly can't ever match when inverting a multi-char | |
450 | # fold for /aa and the quantifier isn't sufficient | |
451 | # to allow it to span to both sides. | |
452 | $op = 0 if $target_has_ascii && $charset eq 'aa' && $both_sides && ( ! $quantifier || $quantifier eq '?') && $parend < 2; | |
453 | ||
454 | # Or for /l | |
455 | $op = 0 if $target_has_latin1 && $charset eq 'l' && $both_sides && ( ! $quantifier || $quantifier eq '?') && $parend < 2; | |
456 | } | |
457 | ||
a2d9a01a KW |
458 | $op = ($op) ? '=~' : '!~'; |
459 | ||
abf4d645 KW |
460 | my $debug .= " uni_semantics=$uni_semantics, should_fail=$should_fail, bracketed=$bracketed, prepend=$prepend, append=$append, parend=$parend, quantifier=$quantifier, l_anchor=$l_anchor, r_anchor=$r_anchor"; |
461 | $debug .= "; pattern_above_latin1=$pattern_above_latin1; utf8_pattern=$utf8_pattern"; | |
462 | my $eval = "my \$c = \"$prepend$lhs$append\"; my \$p = qr/$quantified/i;$upgrade_target$upgrade_pattern \$c $op \$p"; | |
a2d9a01a | 463 | |
abf4d645 | 464 | # XXX Doesn't currently test multi-char folds in pattern |
a2d9a01a | 465 | next if @pattern != 1; |
abf4d645 | 466 | push @eval_tests, format_test($eval, ++$count, $debug); |
a2d9a01a KW |
467 | |
468 | # Group tests | |
469 | if (@eval_tests >= $clump_execs) { | |
abf4d645 | 470 | #eval "use re qw(Debug COMPILE EXECUTE);" . join ";\n", @eval_tests; |
a2d9a01a | 471 | eval join ";\n", @eval_tests; |
abf4d645 KW |
472 | if ($@) { |
473 | fail($@); | |
474 | exit 1; | |
475 | } | |
a2d9a01a KW |
476 | undef @eval_tests; |
477 | } | |
478 | } | |
479 | } | |
480 | } | |
481 | } | |
482 | } | |
483 | } | |
484 | } | |
485 | } | |
486 | } | |
487 | } | |
488 | } | |
489 | } | |
490 | } | |
491 | ||
492 | # Finish up any tests not already done | |
493 | eval join ";\n", @eval_tests; | |
abf4d645 KW |
494 | if ($@) { |
495 | fail($@); | |
496 | exit 1; | |
497 | } | |
a2d9a01a | 498 | |
abf4d645 | 499 | plan($count); |
a2d9a01a KW |
500 | |
501 | 1 |