This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0c77c31c2072b7fdf288c77bf8e11f7eebcc4d46
[perl5.git] / t / re / charset.t
1 # Test the /a, /d, etc regex modifiers
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 use strict;
10 use warnings;
11 use Config;
12
13 plan('no_plan');
14
15 # Each case is a valid element of its hash key.  Choose, where available, an
16 # ASCII-range, Latin-1 non-ASCII range, and above Latin1 range code point.
17 my %testcases = (
18     '\w' => [ ord("A"), 0xE2, 0x16B ],   # Below expects these to all be alpha
19     '\d' => [ ord("0"), 0x0662 ],
20     '\s' => [ ord("\t"), 0xA0, 0x1680 ],  # Below expects these to be [:blank:]
21     '[:cntrl:]' => [ 0x00, 0x88 ],
22     '[:graph:]' => [ ord("&"), 0xF7, 0x02C7 ], # Below expects these to be
23                                                # [:print:]
24     '[:lower:]' => [ ord("g"), 0xE3, 0x0127 ],
25     '[:punct:]' => [ ord("!"), 0xBF, 0x055C ],
26     '[:upper:]' => [ ord("G"), 0xC3, 0x0126 ],
27     '[:xdigit:]' => [ ord("4"), 0xFF15 ],
28 );
29
30 $testcases{'[:digit:]'} = $testcases{'\d'};
31 $testcases{'[:alnum:]'} = $testcases{'\w'};
32 $testcases{'[:alpha:]'} = $testcases{'\w'};
33 $testcases{'[:blank:]'} = $testcases{'\s'};
34 $testcases{'[:print:]'} = $testcases{'[:graph:]'};
35 $testcases{'[:space:]'} = $testcases{'\s'};
36 $testcases{'[:word:]'} = $testcases{'\w'};
37
38 my @charsets = qw(a d u aa);
39 if (! is_miniperl() && $Config{d_setlocale}) {
40     require POSIX;
41     my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // "";
42     if ($current_locale eq 'C') {
43
44         # test for d_setlocale is repeated here because this one is compile
45         # time, and the one above is run time
46         use if $Config{d_setlocale}, 'locale';
47
48         # Some implementations don't have the 128-255 range characters all
49         # mean nothing under the C locale (an example being VMS).  This is
50         # legal, but since we don't know what the right answers should be,
51         # skip the locale tests in that situation.
52         for my $i (128 .. 255) {
53             goto untestable_locale if chr($i) =~ /[[:print:]]/;
54         }
55         push @charsets, 'l';
56     untestable_locale:
57     }
58 }
59
60 # For each possible character set...
61 foreach my $charset (@charsets) {
62
63     # And in utf8 or not
64     foreach my $upgrade ("", 'utf8::upgrade($a); ') {
65
66         # reverse gets the, \w, \s, \d first.
67         for my $class (reverse sort keys %testcases) {
68
69             # The complement of \w is \W; of [:posix:] is [:^posix:]
70             my $complement = $class;
71             if ($complement !~ s/ ( \[: ) /$1^/x) {
72                 $complement = uc($class);
73             }
74
75             # For each test case
76             foreach my $ord (@{$testcases{$class}}) {
77                 my $char = display(chr($ord));
78
79                 # > 255 already implies upgraded.  Skip the ones that don't
80                 # have an explicit upgrade.  This shows more clearly in the
81                 # output which tests are in utf8, or not.
82                 next if $ord > 255 && ! $upgrade;
83
84                 my $reason = "";    # Explanation output with each test
85                 my $neg_reason = "";
86                 my $match = 1;      # Calculated whether test regex should
87                                     # match or not
88
89                 # Everything always matches in ASCII, or under /u
90                 if ($ord < 128 || $charset eq 'u') {
91                     $reason = "\"$char\" is a $class under /$charset";
92                     $neg_reason = "\"$char\" is not a $complement under /$charset";
93                 }
94                 elsif ($charset eq "a" || $charset eq "aa") {
95                     $match = 0;
96                     $reason = "\"$char\" is non-ASCII, which can't be a $class under /a";
97                     $neg_reason = "\"$char\" is non-ASCII, which is a $complement under /a";
98                 }
99                 elsif ($ord > 255) {
100                     $reason = "\"$char\" is a $class under /$charset";
101                     $neg_reason = "\"$char\" is not a $complement under /$charset";
102                 }
103                 elsif ($charset eq 'l') {
104
105                     # We are using the C locale, which is essentially ASCII,
106                     # but under utf8, the above-latin1 chars are treated as
107                     # Unicode)
108                     $reason = "\"$char\" is not a $class in the C locale under /l";
109                     $neg_reason = "\"$char\" is a $complement in the C locale under /l";
110                     $match = 0;
111                 }
112                 elsif ($upgrade) {
113                     $reason = "\"$char\" is a $class in utf8 under /d";
114                     $neg_reason = "\"$char\" is not a $complement in utf8 under /d";
115                 }
116                 else {
117                     $reason = "\"$char\" is above-ASCII latin1, which requires utf8 to be a $class under /d";
118                     $neg_reason = "\"$char\" is above-ASCII latin1, which is a $complement under /d (unless in utf8)";
119                     $match = 0;
120                 }
121                 $reason = "; $reason" if $reason;
122                 $neg_reason = "; $neg_reason" if $neg_reason;
123
124                 my $op;
125                 my $neg_op;
126                 if ($match) {
127                     $op = '=~';
128                     $neg_op = '!~';
129                 }
130                 else {
131                     $op = '!~';
132                     $neg_op = '=~';
133                 }
134
135                 # In [...] or not
136                 foreach my $bracketed (0, 1) {
137                     my $lb = "";
138                     my $rb = "";
139                     if ($bracketed) {
140
141                         # Adds an extra char to the character class to make sure
142                         # that the class doesn't get optimized away.
143                         $lb = ($bracketed) ? '[_' : "";
144                         $rb = ($bracketed) ? ']' : "";
145                     }
146                     else {  # [:posix:] must be inside outer [ ]
147                         next if $class =~ /\[/;
148                     }
149
150                     my $length = 10;    # For regexec.c regrepeat() cases by
151                                         # matching more than one item
152                     # Test both class and its complement, and with one or more
153                     # than one item to match.
154                     foreach my $eval (
155                         qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: $lb$class$rb ) /x],
156                         qq[my \$a = "$char" x $length; $upgrade\$a $op qr/ (?$charset: $lb$class$rb\{$length} ) /x],
157                     ) {
158                         ok (eval $eval, $eval . $reason);
159                     }
160                     foreach my $eval (
161                         qq[my \$a = "$char"; $upgrade\$a $neg_op qr/ (?$charset: $lb$complement$rb ) /x],
162                         qq[my \$a = "$char" x $length; $upgrade\$a $neg_op qr/ (?$charset: $lb$complement$rb\{$length} ) /x],
163                     ) {
164                         ok (eval $eval, $eval . $neg_reason);
165                     }
166                 }
167
168                 next if $class ne '\w';
169
170                 # Test \b, \B at beginning and end of string
171                 foreach my $eval (
172                     qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: ^ \\b . ) /x],
173                     qq[my \$a = "$char"; $upgrade\$a $op qr/ (?$charset: . \\b \$) /x],
174                 ) {
175                     ok (eval $eval, $eval . $reason);
176                 }
177                 foreach my $eval (
178                     qq[my \$a = "$char"; $upgrade\$a $neg_op qr/(?$charset: ^ \\B . ) /x],
179                     qq[my \$a = "$char"; $upgrade\$a $neg_op qr/(?$charset: . \\B \$ ) /x],
180                 ) {
181                     ok (eval $eval, $eval . $neg_reason);
182                 }
183
184                 # Test \b, \B adjacent to a non-word char, both before it and
185                 # after.  We test with ASCII, Latin1 and Unicode non-word chars
186                 foreach my $space_ord (@{$testcases{'\s'}}) {
187
188                     # Useless to try to test non-utf8 when the ord itself
189                     # forces utf8
190                     next if $space_ord > 255 && ! $upgrade;
191
192                     my $space = display(chr $space_ord);
193
194                     foreach my $eval (
195                         qq[my \$a = "$space$char"; $upgrade\$a $op qr/ (?$charset: . \\b . ) /x],
196                         qq[my \$a = "$char$space"; $upgrade\$a $op qr/ (?$charset: . \\b . ) /x],
197                     ) {
198                         ok (eval $eval, $eval . $reason . "; \"$space\" is not a \\w");
199                     }
200                     foreach my $eval (
201                         qq[my \$a = "$space$char"; $upgrade\$a $neg_op qr/ (?$charset: . \\B . ) /x],
202                         qq[my \$a = "$char$space"; $upgrade\$a $neg_op qr/ (?$charset: . \\B . ) /x],
203                     ) {
204                         ok (eval $eval, $eval . $neg_reason . "; \"$space\" is not a \\w");
205                     }
206                 }
207
208                 # Test \b, \B in the middle of two nominally word chars, but
209                 # one or both may be considered non-word depending on range
210                 # and charset.
211                 foreach my $other_ord (@{$testcases{'\w'}}) {
212                     next if $other_ord > 255 && ! $upgrade;
213                     my $other = display(chr $other_ord);
214
215                     # Determine if the other char is a word char in current
216                     # circumstances
217                     my $other_is_word = 1;
218                     my $other_reason = "\"$other\" is a $class under /$charset";
219                     my $other_neg_reason = "\"$other\" is not a $complement under /$charset";
220                     if ($other_ord > 127
221                         && $charset ne 'u'
222                         && (($charset eq "a" || $charset eq "aa")
223                             || ($other_ord < 256 && ($charset eq 'l' || ! $upgrade))))
224                     {
225                         $other_is_word = 0;
226                         $other_reason = "\"$other\" is not a $class under /$charset";
227                         $other_neg_reason = "\"$other\" is a $complement under /$charset";
228                     }
229                     my $both_reason = $reason;
230                     $both_reason .= "; $other_reason" if $other_ord != $ord;
231                     my $both_neg_reason = $neg_reason;
232                     $both_neg_reason .= "; $other_neg_reason" if $other_ord != $ord;
233
234                     # If both are the same wordness, then \b will fail; \B
235                     # succeed
236                     if ($match == $other_is_word) {
237                         $op = '!~';
238                         $neg_op = '=~';
239                     }
240                     else {
241                         $op = '=~';
242                         $neg_op = '!~';
243                     }
244
245                     foreach my $eval (
246                         qq[my \$a = "$other$char"; $upgrade\$a $op qr/ (?$charset: $other \\b $char ) /x],
247                         qq[my \$a = "$char$other"; $upgrade\$a $op qr/ (?$charset: $char \\b $other ) /x],
248                     ) {
249                         ok (eval $eval, $eval . $both_reason);
250                     }
251                     foreach my $eval (
252                         qq[my \$a = "$other$char"; $upgrade\$a $neg_op qr/ (?$charset: $other \\B $char ) /x],
253                         qq[my \$a = "$char$other"; $upgrade\$a $neg_op qr/ (?$charset: $char \\B $other ) /x],
254                     ) {
255                         ok (eval $eval, $eval . $both_neg_reason);
256                     }
257
258                     next if $other_ord == $ord;
259
260                     # These start with the \b or \B.  They are included, based
261                     # on source code analysis, to force the testing of the FBC
262                     # (find_by_class) portions of regexec.c.
263                     foreach my $eval (
264                         qq[my \$a = "$other$char"; $upgrade\$a $op qr/ (?$charset: \\b $char ) /x],
265                         qq[my \$a = "$char$other"; $upgrade\$a $op qr/ (?$charset: \\b $other ) /x],
266                     ) {
267                         ok (eval $eval, $eval . $both_reason);
268                     }
269                     foreach my $eval (
270                         qq[my \$a = "$other$char"; $upgrade\$a $neg_op qr/ (?$charset: \\B $char ) /x],
271                         qq[my \$a = "$char$other"; $upgrade\$a $neg_op qr/ (?$charset: \\B $other ) /x],
272                     ) {
273                         ok (eval $eval, $eval . $both_neg_reason);
274                     }
275                 }
276             } # End of each test case in a class
277         } # End of \w, \s, ...
278     } # End of utf8 upgraded or not
279 }
280
281 plan(curr_test() - 1);