This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Skip pat_re_eval.t in minitest, as it uses re, which needs dynamic loading.
[perl5.git] / t / re / regexp_unicode_prop.t
CommitLineData
84281c31
A
1#!./perl
2#
3# Tests that have to do with checking whether characters have (or not have)
4# certain Unicode properties; belong (or not belong) to blocks, scripts, etc.
5#
6
7use strict;
8use warnings;
9use 5.010;
10
11my $IS_EBCDIC = ord ('A') == 193;
12
13sub run_tests;
14
15#
16# This is the data to test.
17#
18# This is a hash; keys are the property to test.
19# Values are arrays containing characters to test. The characters can
20# have the following formats:
21# '\N{CHARACTER NAME}' - Use character with that name
22# '\x{1234}' - Use character with that hex escape
23# '0x1234' - Use chr() to get that character
24# "a" - Character to use
25#
26# If a character entry starts with ! the character does not belong to the class
27#
28# If the class is just single letter, we use both \pL and \p{L}
29#
30
31use charnames ':full';
32
33my @CLASSES = (
34 L => ["a", "A"],
35 Ll => ["b", "!B"],
36 Lu => ["!c", "C"],
37 IsLl => ["d", "!D"],
38 IsLu => ["!e", "E"],
39 LC => ["f", "!1"],
40 'L&' => ["g", "!2"],
41 'Lowercase Letter' => ["h", "!H"],
42
43 Common => ["!i", "3"],
44 Inherited => ["!j", '\x{300}'],
45
46 InBasicLatin => ['\N{LATIN CAPITAL LETTER A}'],
47 InLatin1Supplement => ['\N{LATIN CAPITAL LETTER A WITH GRAVE}'],
48 InLatinExtendedA => ['\N{LATIN CAPITAL LETTER A WITH MACRON}'],
49 InLatinExtendedB => ['\N{LATIN SMALL LETTER B WITH STROKE}'],
50 InKatakana => ['\N{KATAKANA LETTER SMALL A}'],
51 IsLatin => ["0x100", "0x212b"],
52 IsHebrew => ["0x5d0", "0xfb4f"],
53 IsGreek => ["0x37a", "0x386", "!0x387", "0x388",
54 "0x38a", "!0x38b", "0x38c"],
55 HangulSyllables => ['\x{AC00}'],
56 'Script=Latin' => ['\x{0100}'],
57 'Block=LatinExtendedA' => ['\x{0100}'],
58 'Category=UppercaseLetter' => ['\x{0100}'],
59
60 #
61 # It's ok to repeat class names.
62 #
63 InLatin1Supplement =>
64 $IS_EBCDIC ? ['!\x{7f}', '\x{80}', '!\x{100}']
65 : ['!\x{7f}', '\x{80}', '\x{ff}', '!\x{100}'],
66 InLatinExtendedA =>
67 ['!\x{7f}', '!\x{80}', '!\x{ff}', '\x{100}'],
68
69 #
70 # Properties are case-insensitive, and may have whitespace,
71 # dashes and underscores.
72 #
73 'in-latin1_SUPPLEMENT' => ['\x{80}',
74 '\N{LATIN SMALL LETTER Y WITH DIAERESIS}'],
75 ' ^ In Latin 1 Supplement '
76 => ['!\x{80}', '\N{COFFIN}'],
77 'latin-1 supplement' => ['\x{80}', "0xDF"],
78
79);
80
81my @USER_DEFINED_PROPERTIES = (
82 #
83 # User defined properties
84 #
85 InKana1 => ['\x{3040}', '!\x{303F}'],
86 InKana2 => ['\x{3040}', '!\x{303F}'],
87 InKana3 => ['\x{3041}', '!\x{3040}'],
88 InNotKana => ['\x{3040}', '!\x{3041}'],
89 InConsonant => ['d', '!e'],
90 IsSyriac1 => ['\x{0712}', '!\x{072F}'],
9c8ea558 91 '# User-defined character properties may lack \n at the end',
84281c31
A
92 InGreekSmall => ['\N{GREEK SMALL LETTER PI}',
93 '\N{GREEK SMALL LETTER FINAL SIGMA}'],
94 InGreekCapital => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'],
95 Dash => ['-'],
96 ASCII_Hex_Digit => ['!-', 'A'],
d658a8a8 97 IsAsciiHexAndDash => ['-', 'A'],
84281c31
A
98);
99
19c4061a
KW
100my @USER_CASELESS_PROPERTIES = (
101 #
102 # User defined properties which differ depending on /i. Second entry is
103 # false regularly, true under /i
104 #
105 'IsMyUpper' => ["M", "!m" ],
106);
107
84281c31
A
108
109#
110# From the short properties we populate POSIX-like classes.
111#
112my %SHORT_PROPERTIES = (
113 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'],
114 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'],
115 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'],
99870f4d
KW
116 # is also in other alphabetic
117 'Mn' => ['\N{HEBREW POINT RAFE}'],
84281c31
A
118 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'],
119 'Pc' => ["_"],
120 'Po' => ["!"],
121 'Zs' => [" "],
122 'Cc' => ['\x{00}'],
123);
124
125#
126# Illegal properties
127#
d658a8a8
DM
128my @ILLEGAL_PROPERTIES =
129 qw[q qrst f foo isfoo infoo ISfoo INfoo Is::foo In::foo];
84281c31
A
130
131my %d;
132
133while (my ($class, $chars) = each %SHORT_PROPERTIES) {
134 push @{$d {IsAlpha}} => map {$class =~ /^[LM]/ ? $_ : "!$_"} @$chars;
135 push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars;
136 push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}'
137 ? $_ : "!$_"} @$chars;
138 push @{$d {IsCntrl}} => map {$class =~ /^C/ ? $_ : "!$_"} @$chars;
139 push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars;
140 push @{$d {IsDigit}} => map {$class =~ /^Nd$/ ? $_ : "!$_"} @$chars;
141 push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/
142 ? $_ : "!$_"} @$chars;
143 push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/
144 ? $_ : "!$_"} @$chars;
145 push @{$d {IsLower}} => map {$class =~ /^Ll$/ ? $_ : "!$_"} @$chars;
146 push @{$d {IsUpper}} => map {$class =~ /^L[ut]/ ? $_ : "!$_"} @$chars;
147 push @{$d {IsPunct}} => map {$class =~ /^P/ ? $_ : "!$_"} @$chars;
148 push @{$d {IsWord}} => map {$class =~ /^[LMN]/ || $_ eq "_"
149 ? $_ : "!$_"} @$chars;
150 push @{$d {IsSpace}} => map {$class =~ /^Z/ ||
151 length ($_) == 1 && ord ($_) >= 0x09
152 && ord ($_) <= 0x0D
153 ? $_ : "!$_"} @$chars;
154}
155
156delete $d {IsASCII} if $IS_EBCDIC;
157
158push @CLASSES => "# Short properties" => %SHORT_PROPERTIES,
159 "# POSIX like properties" => %d,
160 "# User defined properties" => @USER_DEFINED_PROPERTIES;
161
162
163#
164# Calculate the number of tests.
165#
166my $count = 0;
167for (my $i = 0; $i < @CLASSES; $i += 2) {
168 $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/;
169 $count += (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]};
170}
171$count += 2 * @ILLEGAL_PROPERTIES;
172$count += 2 * grep {length $_ == 1} @ILLEGAL_PROPERTIES;
19c4061a 173$count += 4 * @USER_CASELESS_PROPERTIES;
84281c31
A
174
175my $tests = 0;
176
177say "1..$count";
178
179run_tests unless caller ();
180
181sub match {
19c4061a
KW
182 my ($char, $match, $nomatch, $caseless) = @_;
183 $caseless = "" unless defined $caseless;
184 $caseless = 'i' if $caseless;
84281c31
A
185
186 my ($str, $name);
187
188 given ($char) {
189 when (/^\\/) {
190 $str = eval qq ["$char"];
191 $name = qq ["$char"];
192 }
193 when (/^0x([0-9A-Fa-f]+)$/) {
194 $str = chr hex $1;
195 $name = "chr ($char)";
196 }
197 default {
198 $str = $char;
199 $name = qq ["$char"];
200 }
201 }
202
19c4061a
KW
203 undef $@;
204 my $match_pat = eval "qr/$match/$caseless";
205 print "not " if $@ || ! ($str =~ /$match_pat/);
206 print "ok ", ++ $tests, " - $name =~ $match_pat\n";
207
208 undef $@;
209 my $nomatch_pat = eval "qr/$nomatch/$caseless";
210 print "not " if $@ || ! ($str !~ /$nomatch_pat/);
211 print "ok ", ++ $tests, " - $name !~ $nomatch_pat\n";
84281c31
A
212}
213
214sub run_tests {
215
216 while (@CLASSES) {
217 my $class = shift @CLASSES;
218 if ($class =~ /^\h*#\h*(.*)/) {
219 print "# $1\n";
220 next;
221 }
222 last unless @CLASSES;
223 my $chars = shift @CLASSES;
224 my @in = grep {!/^!./} @$chars;
225 my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars;
226 my $in_pat = eval qq ['\\p{$class}'];
227 my $out_pat = eval qq ['\\P{$class}'];
228
229 match $_, $in_pat, $out_pat for @in;
230 match $_, $out_pat, $in_pat for @out;
231
9c8ea558 232 if (1 == length $class) { # Repeat without braces if name length 1
84281c31
A
233 my $in_pat = eval qq ['\\p$class'];
234 my $out_pat = eval qq ['\\P$class'];
235
236 match $_, $in_pat, $out_pat for @in;
237 match $_, $out_pat, $in_pat for @out;
238 }
239 }
240
241
242 my $pat = qr /^Can't find Unicode property definition/;
243 print "# Illegal properties\n";
244 foreach my $p (@ILLEGAL_PROPERTIES) {
245 undef $@;
246 my $r = eval "'a' =~ /\\p{$p}/; 1";
247 print "not " unless !$r && $@ && $@ =~ $pat;
248 print "ok ", ++ $tests, " - Unknown Unicode property \\p{$p}\n";
249 undef $@;
250 my $s = eval "'a' =~ /\\P{$p}/; 1";
251 print "not " unless !$s && $@ && $@ =~ $pat;
252 print "ok ", ++ $tests, " - Unknown Unicode property \\P{$p}\n";
253 if (length $p == 1) {
254 undef $@;
255 my $r = eval "'a' =~ /\\p$p/; 1";
256 print "not " unless !$r && $@ && $@ =~ $pat;
257 print "ok ", ++ $tests, " - Unknown Unicode property \\p$p\n";
258 undef $@;
259 my $s = eval "'a' =~ /\\P$p/; 1";
260 print "not " unless !$s && $@ && $@ =~ $pat;
261 print "ok ", ++ $tests, " - Unknown Unicode property \\P$p\n";
262 }
263 }
19c4061a
KW
264
265 print "# User-defined properties with /i differences\n";
266 foreach my $class (shift @USER_CASELESS_PROPERTIES) {
267 my $chars_ref = shift @USER_CASELESS_PROPERTIES;
268 my @in = grep {!/^!./} @$chars_ref;
269 my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars_ref;
270 my $in_pat = eval qq ['\\p{$class}'];
271 my $out_pat = eval qq ['\\P{$class}'];
272
273 # Verify works as regularly for not /i
274 match $_, $in_pat, $out_pat for @in;
275 match $_, $out_pat, $in_pat for @out;
276
277 # Verify that adding /i doesn't change the in set.
278 match $_, $in_pat, $out_pat, 'i' for @in;
279
280 # Verify that adding /i does change the out set to match.
281 match $_, $in_pat, $out_pat, 'i' for @out;
282 }
84281c31
A
283}
284
285
286#
287# User defined properties
288#
289
290sub InKana1 {<<'--'}
2913040 309F
29230A0 30FF
293--
294
295sub InKana2 {<<'--'}
296+utf8::InHiragana
297+utf8::InKatakana
298--
299
300sub InKana3 {<<'--'}
301+utf8::InHiragana
302+utf8::InKatakana
303-utf8::IsCn
304--
305
306sub InNotKana {<<'--'}
307!utf8::InHiragana
308-utf8::InKatakana
309+utf8::IsCn
310--
311
312sub InConsonant {<<'--'} # Not EBCDIC-aware.
3130061 007f
314-0061
315-0065
316-0069
317-006f
318-0075
319--
320
321sub IsSyriac1 {<<'--'}
3220712 072C
3230730 074A
324--
325
84281c31
A
326sub InGreekSmall {return "03B1\t03C9"}
327sub InGreekCapital {return "0391\t03A9\n-03A2"}
328
d658a8a8 329sub IsAsciiHexAndDash {<<'--'}
84281c31
A
330+utf8::ASCII_Hex_Digit
331+utf8::Dash
332--
333
19c4061a
KW
334sub IsMyUpper {
335 my $caseless = shift;
336 if ($caseless) {
337 return "0041\t005A\n0061\t007A"
338 }
339 else {
340 return "0041\t005A"
341 }
342}
343
d658a8a8
DM
344# fake user-defined properties; these subs shouldn't be called, because
345# their names don't start with In or Is
346
347sub f { die }
348sub foo { die }
349sub isfoo { die }
350sub infoo { die }
351sub ISfoo { die }
352sub INfoo { die }
353sub Is::foo { die }
354sub In::foo { die }
84281c31 355__END__