This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/re/regex_sets.t: Add some tests
[perl5.git] / t / re / regex_sets.t
1 #!./perl
2
3 # This tests (?[...]).  XXX These are just basic tests, as full ones would be
4 # best done with an infrastructure change to allow getting out the inversion
5 # list of the constructed set and then comparing it character by character
6 # with the expected result.
7
8 BEGIN {
9     chdir 't' if -d 't';
10     @INC = ('../lib','.','../ext/re');
11     require './test.pl';
12     require './charset_tools.pl';
13     require './loc_tools.pl';
14     skip_all_without_unicode_tables();
15 }
16
17 use strict;
18 use warnings;
19
20 $| = 1;
21
22 use utf8;
23 no warnings 'experimental::regex_sets';
24
25 like("a", qr/(?[ [a]      # This is a comment
26                     ])/, 'Can ignore a comment');
27 like("a", qr/(?[ [a]      # [[:notaclass:]]
28                     ])/, 'A comment isn\'t parsed');
29 unlike(uni_to_native("\x85"), qr/(?[ \t\85 ])/, 'NEL is white space');
30 like(uni_to_native("\x85"), qr/(?[ \t + \\85 ])/, 'can escape NEL to match');
31 like(uni_to_native("\x85"), qr/(?[ [\\85] ])/, '... including within nested []');
32 like("\t", qr/(?[ \t + \\85 ])/, 'can do basic union');
33 like("\cK", qr/(?[ \s ])/, '\s matches \cK');
34 unlike("\cK", qr/(?[ \s - \cK ])/, 'can do basic subtraction');
35 like(" ", qr/(?[ \s - \cK ])/, 'can do basic subtraction');
36 like(":", qr/(?[ [:] ])/, '[:] is not a posix class');
37 unlike("\t", qr/(?[ ! \t ])/, 'can do basic complement');
38 like("\t", qr/(?[ ! [ ^ \t ] ])/, 'can do basic complement');
39 unlike("\r", qr/(?[ \t ])/, '\r doesn\'t match \t ');
40 like("\r", qr/(?[ ! \t ])/, 'can do basic complement');
41 like("0", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection');
42 unlike("A", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection');
43 like("0", qr/(?[[:word:]&[:digit:]])/, 'spaces around internal [] aren\'t required');
44
45 like("a", qr/(?[ [a] | [b] ])/, '| means union');
46 like("b", qr/(?[ [a] | [b] ])/, '| means union');
47 unlike("c", qr/(?[ [a] | [b] ])/, '| means union');
48
49 like("a", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
50 unlike("b", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
51 like("c", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works');
52
53 like("2", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping');
54 unlike("a", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping');
55
56 unlike("\x{17f}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i doesn\'t affect \p{}');
57 like("\N{KELVIN SIGN}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i does affect literals');
58
59 my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
60 my $thai_or_lao_digit = qr/(?[ \p{Digit} & $thai_or_lao ])/;
61 like("\N{THAI DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
62 unlike(chr(ord("\N{THAI DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
63 like("\N{THAI DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
64 unlike(chr(ord("\N{THAI DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
65 like("\N{LAO DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
66 unlike(chr(ord("\N{LAO DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
67 like("\N{LAO DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
68 unlike(chr(ord("\N{LAO DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works');
69
70 my $ascii_word = qr/(?[ \w ])/a;
71 my $ascii_digits_plus_all_of_arabic = qr/(?[ \p{Arabic} + \p{Digit} & $ascii_word ])/;
72 like("9", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII in the set");
73 unlike("A", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII not in the set");
74 unlike("\N{BENGALI DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII not in either set");
75 unlike("\N{BENGALI LETTER A}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII in one set");
76 like("\N{ARABIC LETTER HAMZA}", $ascii_digits_plus_all_of_arabic, "intersection has higher precedence than union");
77 like("\N{EXTENDED ARABIC-INDIC DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "intersection has higher precedence than union");
78
79 like("\r", qr/(?[ \p{lb=cr} ])/, '\r matches \p{lb=cr}');
80 unlike("\r", qr/(?[ ! \p{lb=cr} ])/, '\r doesnt match ! \p{lb=cr}');
81 like("\r", qr/(?[ ! ! \p{lb=cr} ])/, 'Two ! ! are the original');
82 unlike("\r", qr/(?[ ! ! ! \p{lb=cr} ])/, 'Three ! ! ! are the complement');
83 # left associatve
84
85 my $kelvin = qr/(?[ \N{KELVIN SIGN} ])/;
86 my $fold = qr/(?[ $kelvin ])/i;
87 like("\N{KELVIN SIGN}", $kelvin, '"\N{KELVIN SIGN}" matches compiled qr/(?[ \N{KELVIN SIGN} ])/');
88 unlike("K", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one");
89 unlike("k", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one");
90
91 my $kelvin_fold = qr/(?[ \N{KELVIN SIGN} ])/i;
92 my $still_fold = qr/(?[ $kelvin_fold ])/;
93 like("K", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i");
94 like("k", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i");
95
96 eval 'my $x = qr/(?[ [a] ])/; qr/(?[ $x ])/';
97 is($@, "", 'qr/(?[ [a] ])/ can be interpolated');
98
99 like("B", qr/(?[ [B] | ! ( [^B] ) ])/, "[perl #125892]");
100
101 like("a", qr/(?[ (?#comment) [a]])/, "Can have (?#comments)");
102
103 if (! is_miniperl() && locales_enabled('LC_CTYPE')) {
104     my $utf8_locale = find_utf8_ctype_locale;
105     SKIP: {
106         skip("No utf8 locale available on this platform", 8) unless $utf8_locale;
107
108         setlocale(&POSIX::LC_ALL, "C");
109         use locale;
110
111         $kelvin_fold = qr/(?[ \N{KELVIN SIGN} ])/i;
112         my $single_char_class = qr/(?[ \: ])/;
113
114         setlocale(&POSIX::LC_ALL, $utf8_locale);
115
116         like("\N{KELVIN SIGN}", $kelvin_fold,
117              '(?[ \N{KELVIN SIGN} ]) matches itself under /i in UTF8-locale');
118         like("K", $kelvin_fold,
119                 '(?[ \N{KELVIN SIGN} ]) matches "K" under /i in UTF8-locale');
120         like("k", $kelvin_fold,
121                 '(?[ \N{KELVIN SIGN} ]) matches "k" under /i in UTF8-locale');
122         like(":", $single_char_class,
123              '(?[ : ]) matches itself in UTF8-locale (a single character class)');
124
125         setlocale(&POSIX::LC_ALL, "C");
126
127         # These should generate warnings (the above 4 shouldn't), but like()
128         # suppresses them, so the warnings tests are in t/lib/warnings/regexec
129         $^W = 0;   # Suppress the warnings that occur when run by hand with
130                    # the -w option
131         like("\N{KELVIN SIGN}", $kelvin_fold,
132              '(?[ \N{KELVIN SIGN} ]) matches itself under /i in C locale');
133         like("K", $kelvin_fold,
134                 '(?[ \N{KELVIN SIGN} ]) matches "K" under /i in C locale');
135         like("k", $kelvin_fold,
136                 '(?[ \N{KELVIN SIGN} ]) matches "k" under /i in C locale');
137         like(":", $single_char_class,
138              '(?[ : ]) matches itself in C locale (a single character class)');
139     }
140 }
141
142 # Tests that no warnings given for valid Unicode digit range.
143 my $arabic_digits = qr/(?[ [ ٠ - ٩ ] ])/;
144 for my $char ("٠", "٥", "٩") {
145     use charnames ();
146     my @got = capture_warnings(sub {
147                 like("٠", $arabic_digits, "Matches "
148                                                 . charnames::viacode(ord $char));
149             });
150     is (@got, 0, "... without warnings");
151 }
152
153 # RT #126181: \cX behaves strangely inside (?[])
154 {
155         no warnings qw(syntax regexp);
156
157         eval { $_ = '/(?[(\c]) /'; qr/$_/ };
158         like($@, qr/^Syntax error/, '/(?[(\c]) / should not panic');
159         eval { $_ = '(?[\c#]' . "\n])"; qr/$_/ };
160         like($@, qr/^Syntax error/, '/(?[(\c]) / should not panic');
161         eval { $_ = '(?[(\c])'; qr/$_/ };
162         like($@, qr/^Syntax error/, '/(?[(\c])/ should be a syntax error');
163         eval { $_ = '(?[(\c]) ]\b'; qr/$_/ };
164         like($@, qr/^Syntax error/, '/(?[(\c]) ]\b/ should be a syntax error');
165         eval { $_ = '(?[\c[]](])'; qr/$_/ };
166         like($@, qr/^Syntax error/, '/(?[\c[]](])/ should be a syntax error');
167         like("\c#", qr/(?[\c#])/, '\c# should match itself');
168         like("\c[", qr/(?[\c[])/, '\c[ should match itself');
169         like("\c\ ", qr/(?[\c\])/, '\c\ should match itself');
170         like("\c]", qr/(?[\c]])/, '\c] should match itself');
171 }
172
173 # RT #126481 !! with syntax error panics
174 {
175     fresh_perl_like('no warnings "experimental::regex_sets"; qr/(?[ ! ! (\w])/',
176                     qr/^Unmatched \(/, {},
177                     'qr/(?[ ! ! (\w])/ doesnt panic');
178     # The following didn't panic before, but easy to add this here with a
179     # paren between the !!
180     fresh_perl_like('no warnings "experimental::regex_sets";qr/(?[ ! ( ! (\w)])/',
181                     qr/^Unmatched \(/, {},
182                     'qr/qr/(?[ ! ( ! (\w)])/');
183 }
184
185 done_testing();
186
187 1;