1 # Test the /a, /d, etc regex modifiers
14 # Each case is a valid element of its hash key. Choose, where available, an
15 # ASCII-range, Latin-1 non-ASCII range, and above Latin1 range code point.
17 '\w' => [ ord("A"), 0xE2, 0x16B ], # Below expects these to all be alpha
18 '\d' => [ ord("0"), 0x0662 ],
19 '\s' => [ ord("\t"), 0xA0, 0x1680 ], # Below expects these to be [:blank:]
20 '[:cntrl:]' => [ 0x00, 0x88 ],
21 '[:graph:]' => [ ord("&"), 0xF7, 0x02C7 ], # Below expects these to be
23 '[:lower:]' => [ ord("g"), 0xE3, 0x0127 ],
24 '[:punct:]' => [ ord("!"), 0xBF, 0x055C ],
25 '[:upper:]' => [ ord("G"), 0xC3, 0x0126 ],
26 '[:xdigit:]' => [ ord("4"), 0xFF15 ],
29 $testcases{'[:digit:]'} = $testcases{'\d'};
30 $testcases{'[:alnum:]'} = $testcases{'\w'};
31 $testcases{'[:alpha:]'} = $testcases{'\w'};
32 $testcases{'[:blank:]'} = $testcases{'\s'};
33 $testcases{'[:print:]'} = $testcases{'[:graph:]'};
34 $testcases{'[:space:]'} = $testcases{'\s'};
35 $testcases{'[:word:]'} = $testcases{'\w'};
37 # For each possible character set...
38 foreach my $charset ("d", "u") {
41 foreach my $upgrade ("", 'utf8::upgrade($a); ') {
43 # reverse gets the, \w, \s, \d first.
44 for my $class (reverse sort keys %testcases) {
46 # The complement of \w is \W; of [:posix:] is [:^posix:]
47 my $complement = $class;
48 if ($complement !~ s/ ( \[: ) /$1^/x) {
49 $complement = uc($class);
53 foreach my $ord (@{$testcases{$class}}) {
54 my $char = display(chr($ord));
56 # > 255 already implies upgraded. Skip the ones that don't
57 # have an explicit upgradei. This shows more clearly in the
58 # output which tests are in utf8, or not.
59 next if $ord > 255 && ! $upgrade;
61 my $reason = ""; # Explanation output with each test
62 my $match = 1; # Calculated whether test regex should
65 # Everything always matches in ASCII, or under /u
66 if ($ord < 128 || $charset eq 'u') {
67 $reason = "\"$char\" is a $class under /$charset";
69 elsif ($charset eq "a") {
71 $reason = "\"$char\" is non-ASCII, which can't be a $class under /a";
74 $reason = "\"$char\" is a $class under /$charset";
76 elsif ($charset eq 'l') {
78 # We are using the C locale, which is essentially ASCII,
79 # but under utf8, the above-latin1 chars are treated as
81 $reason = "\"$char\" is not a $class in this locale under /l";
85 $reason = "\"$char\" is a $class in utf8 under /d";
88 $reason = "\"$char\" is latin1, which requires utf8 to be a $class under /d";
91 $reason = "; $reason" if $reason;
105 foreach my $bracketed (0, 1) {
110 # Adds an extra char to the character class to make sure
111 # that the class doesn't get optimized away.
112 $lb = ($bracketed) ? '[_' : "";
113 $rb = ($bracketed) ? ']' : "";
115 else { # [:posix:] must be inside outer [ ]
116 next if $class =~ /\[/;
119 my $length = 10; # For regexec.c regrepeat() cases by
120 # matching more than one item
121 # Test both class and its complement, and with one or more
122 # than one item to match.
124 qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: $lb$class$rb ) /x],
125 qq[my \$a = "$char"; $upgrade\$a $neg_op qr/ (?$charset: $lb$complement$rb ) /x],
126 qq[my \$a = "$char" x $length; $upgrade\$a $op qr/ (?$charset: $lb$class$rb\{$length} ) /x],
127 qq[my \$a = "$char" x $length; $upgrade\$a $neg_op qr/ (?$charset: $lb$complement$rb\{$length} ) /x],
129 ok (eval $eval, $eval . $reason);
133 next if $class ne '\w';
135 # Test \b, \B at beginning and end of string
137 qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: ^ \\b . ) /x],
138 qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: . \\b \$) /x],
139 qq[my \$a = "$char"; $upgrade\$a $neg_op qr/(?$charset: ^ \\B . ) /x],
140 qq[my \$a = "$char"; $upgrade\$a $neg_op qr/(?$charset: . \\B \$ ) /x],
142 ok (eval $eval, $eval . $reason);
145 # Test \b, \B adjacent to a non-word char, both before it and
146 # after. We test with ASCII, Latin1 and Unicode non-word chars
147 foreach my $space_ord (@{$testcases{'\s'}}) {
149 # Useless to try to test non-utf8 when the ord itself
151 next if $space_ord > 255 && ! $upgrade;
153 my $space = display(chr $space_ord);
156 qq[my \$a = "$space$char"; $upgrade\$a $op qr/ (?$charset: . \\b . ) /x],
157 qq[my \$a = "$char$space"; $upgrade\$a $op qr/ (?$charset: . \\b . ) /x],
158 qq[my \$a = "$space$char"; $upgrade\$a $neg_op qr/ (?$charset: . \\B . ) /x],
159 qq[my \$a = "$char$space"; $upgrade\$a $neg_op qr/ (?$charset: . \\B . ) /x],
161 ok (eval $eval, $eval . $reason . "; \"$space\" is not a \\w");
165 # Test \b, \B in the middle of two nominally word chars, but
166 # one or both may be considered non-word depending on range
168 foreach my $other_ord (@{$testcases{'\w'}}) {
169 next if $other_ord > 255 && ! $upgrade;
170 my $other = display(chr $other_ord);
172 # Determine if the other char is a word char in current
174 my $other_is_word = 1;
175 my $other_reason = "\"$other\" is a $class under /$charset";
179 || ($other_ord < 256 && ($charset eq 'l' || ! $upgrade))))
182 $other_reason = "\"$other\" is not a $class under /$charset";
184 my $both_reason = $reason;
185 $both_reason .= "; $other_reason" if $other_ord != $ord;
187 # If both are the same wordness, then \b will fail; \B
189 if ($match == $other_is_word) {
199 qq[my \$a = "$other$char"; $upgrade\$a $op qr/ (?$charset: $other \\b $char ) /x],
200 qq[my \$a = "$char$other"; $upgrade\$a $op qr/ (?$charset: $char \\b $other ) /x],
201 qq[my \$a = "$other$char"; $upgrade\$a $neg_op qr/ (?$charset: $other \\B $char ) /x],
202 qq[my \$a = "$char$other"; $upgrade\$a $neg_op qr/ (?$charset: $char \\B $other ) /x],
204 ok (eval $eval, $eval . $both_reason);
207 next if $other_ord == $ord;
209 # These start with the \b or \B. They are included, based
210 # on source code analysis, to force the testing of the FBC
211 # (find_by_class) portions of regexec.c.
213 qq[my \$a = "$other$char"; $upgrade\$a $op qr/ (?$charset: \\b $char ) /x],
214 qq[my \$a = "$char$other"; $upgrade\$a $op qr/ (?$charset: \\b $other ) /x],
215 qq[my \$a = "$other$char"; $upgrade\$a $neg_op qr/ (?$charset: \\B $char ) /x],
216 qq[my \$a = "$char$other"; $upgrade\$a $neg_op qr/ (?$charset: \\B $other ) /x],
218 ok (eval $eval, $eval . $both_reason);
221 } # End of each test case in a class
222 } # End of \w, \s, ...
223 } # End of utf8 upgraded or not
226 plan(curr_test() - 1);