This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regcomp.c: Fix comment
[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;
61ac831b 9use v5.16;
3b071fee
KW
10use utf8;
11
12# To verify that messages containing the expansions work on UTF-8
13my $utf8_comment;
84281c31 14
d82cefba
KW
15my @warnings;
16local $SIG {__WARN__} = sub {push @warnings, "@_"};
17
f3b02925 18BEGIN {
b5efbd1f 19 chdir 't' if -d 't';
f3b02925
NC
20 require './test.pl';
21 skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec (used by charnames)");
22}
84281c31
A
23
24sub run_tests;
25
3a0825d5
KW
26sub get_str_name($) {
27 my $char = shift;
28
29 my ($str, $name);
30
31 if ($char =~ /^\\/) {
32 $str = eval qq ["$char"];
33 $name = qq ["$char"];
34 }
35 elsif ($char =~ /^0x([0-9A-Fa-f]+)$/) {
36 $str = chr hex $1;
37 $name = "chr ($char)";
38 }
39 else {
40 $str = $char;
41 $name = qq ["$char"];
42 }
43
44 return ($str, $name);
45}
46
84281c31
A
47#
48# This is the data to test.
49#
50# This is a hash; keys are the property to test.
51# Values are arrays containing characters to test. The characters can
52# have the following formats:
53# '\N{CHARACTER NAME}' - Use character with that name
54# '\x{1234}' - Use character with that hex escape
55# '0x1234' - Use chr() to get that character
56# "a" - Character to use
57#
58# If a character entry starts with ! the character does not belong to the class
59#
60# If the class is just single letter, we use both \pL and \p{L}
61#
62
63use charnames ':full';
64
65my @CLASSES = (
66 L => ["a", "A"],
67 Ll => ["b", "!B"],
68 Lu => ["!c", "C"],
69 IsLl => ["d", "!D"],
70 IsLu => ["!e", "E"],
71 LC => ["f", "!1"],
72 'L&' => ["g", "!2"],
73 'Lowercase Letter' => ["h", "!H"],
74
75 Common => ["!i", "3"],
76 Inherited => ["!j", '\x{300}'],
77
78 InBasicLatin => ['\N{LATIN CAPITAL LETTER A}'],
79 InLatin1Supplement => ['\N{LATIN CAPITAL LETTER A WITH GRAVE}'],
80 InLatinExtendedA => ['\N{LATIN CAPITAL LETTER A WITH MACRON}'],
81 InLatinExtendedB => ['\N{LATIN SMALL LETTER B WITH STROKE}'],
82 InKatakana => ['\N{KATAKANA LETTER SMALL A}'],
83 IsLatin => ["0x100", "0x212b"],
84 IsHebrew => ["0x5d0", "0xfb4f"],
85 IsGreek => ["0x37a", "0x386", "!0x387", "0x388",
86 "0x38a", "!0x38b", "0x38c"],
87 HangulSyllables => ['\x{AC00}'],
88 'Script=Latin' => ['\x{0100}'],
89 'Block=LatinExtendedA' => ['\x{0100}'],
90 'Category=UppercaseLetter' => ['\x{0100}'],
91
92 #
93 # It's ok to repeat class names.
94 #
95 InLatin1Supplement =>
425224e1 96 ['!\N{U+7f}', '\N{U+80}', '\N{U+ff}', '!\x{100}'],
84281c31 97 InLatinExtendedA =>
425224e1 98 ['!\N{U+7f}', '!\N{U+80}', '!\N{U+ff}', '\x{100}'],
84281c31
A
99
100 #
101 # Properties are case-insensitive, and may have whitespace,
102 # dashes and underscores.
103 #
425224e1 104 'in-latin1_SUPPLEMENT' => ['\N{U+80}',
84281c31
A
105 '\N{LATIN SMALL LETTER Y WITH DIAERESIS}'],
106 ' ^ In Latin 1 Supplement '
425224e1
KW
107 => ['!\N{U+80}', '\N{COFFIN}'],
108 'latin-1 supplement' => ['\N{U+80}', "0xDF"],
84281c31
A
109
110);
111
327cef2f
KW
112my @USER_DEFINED_PROPERTIES;
113my @USER_CASELESS_PROPERTIES;
3b071fee 114my @USER_ERROR_PROPERTIES;
327cef2f 115my @DEFERRED;
3b071fee 116my $overflow;
327cef2f 117BEGIN {
3b071fee
KW
118 $utf8_comment = "#\N{U+30CD}";
119
120 use Config;
121 $overflow = $Config{uvsize} < 8 ? "80000000" : "80000000000000000";
327cef2f
KW
122
123 # We defined these at compile time, so that the subroutines that they
124 # refer to aren't known, so that we can test properties not known until
125 # runtime
126
127 @USER_DEFINED_PROPERTIES = (
3b9fb374
KW
128 #
129 # User defined properties
130 #
131 InKana1 => ['\x{3040}', '!\x{303F}'],
132 InKana2 => ['\x{3040}', '!\x{303F}'],
133 InKana3 => ['\x{3041}', '!\x{3040}'],
134 InNotKana => ['\x{3040}', '!\x{3041}'],
135 InConsonant => ['d', '!e'],
136 IsSyriac1 => ['\x{0712}', '!\x{072F}'],
137 IsSyriac1KanaMark => ['\x{309A}', '!\x{3090}'],
138 IsSyriac1KanaMark => ['\x{0730}', '!\x{0712}'],
139 '# User-defined character properties may lack \n at the end',
140 InGreekSmall => ['\N{GREEK SMALL LETTER PI}',
141 '\N{GREEK SMALL LETTER FINAL SIGMA}'],
142 InGreekCapital => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'],
143 Dash => ['-'],
144 ASCII_Hex_Digit => ['!-', 'A'],
145 IsAsciiHexAndDash => ['-', 'A'],
3b9fb374
KW
146 );
147
327cef2f 148 @USER_CASELESS_PROPERTIES = (
3b9fb374
KW
149 #
150 # User defined properties which differ depending on /i. Second entry
151 # is false normally, true under /i
152 #
153 'IsMyUpper' => ["M", "!m" ],
e4f9f798 154 'pkg1::pkg2::IsMyLower' => ["a", "!A" ],
3b9fb374 155 );
19c4061a 156
3b071fee
KW
157 @USER_ERROR_PROPERTIES = (
158 'IsOverflow' => qr/Code point too large in (?#
159 )"0\t$overflow$utf8_comment" in expansion of (?#
160 )main::IsOverflow/,
161 'InRecursedA' => qr/Infinite recursion in user-defined property (?#
162 )"main::InRecursedA" in expansion of (?#
163 )main::InRecursedC in expansion of (?#
164 )main::InRecursedB in expansion of (?#
165 )main::InRecursedA/,
166 'IsRangeReversed' => qr/Illegal range in "200 100$utf8_comment" in (?#
167 )expansion of main::IsRangeReversed/,
168 'IsNonHex' => qr/Can't find Unicode property definition (?#
169 )"BEEF CAGED" in expansion of main::IsNonHex/,
170
171 # Could have \n, hence /s
172 'IsDeath' => qr/Died.* in expansion of main::IsDeath/s,
173 );
84281c31 174
327cef2f
KW
175 # Now create a list of properties whose definitions won't be known at
176 # runtime. The qr// below thus will have forward references to them, and
177 # when matched at runtime will not know what's in the property definition
178 my @DEFERRABLE_USER_DEFINED_PROPERTIES;
179 push @DEFERRABLE_USER_DEFINED_PROPERTIES, @USER_DEFINED_PROPERTIES;
180 push @DEFERRABLE_USER_DEFINED_PROPERTIES, @USER_CASELESS_PROPERTIES;
3b071fee 181 unshift @DEFERRABLE_USER_DEFINED_PROPERTIES, @USER_ERROR_PROPERTIES;
327cef2f
KW
182 for (my $i = 0; $i < @DEFERRABLE_USER_DEFINED_PROPERTIES; $i+=2) {
183 my $property = $DEFERRABLE_USER_DEFINED_PROPERTIES[$i];
184 if ($property =~ / ^ \# /x) {
185 $i++;
186 redo;
187 }
188
189 # Only do this for the properties in the list that are user-defined
190 next if ($property !~ / ( ^ | :: ) I[ns] /x);
191
192 push @DEFERRED, qr/\p{$property}/,
193 $DEFERRABLE_USER_DEFINED_PROPERTIES[$i+1];
194 }
195}
196
197# These override the official ones, so if found before defined, the official
198# ones prevail, so can't test deferred definition
199my @OVERRIDING_USER_DEFINED_PROPERTIES = (
200 InLatin1 => ['\x{0100}', '!\x{00FF}'],
201);
202
84281c31
A
203#
204# From the short properties we populate POSIX-like classes.
205#
206my %SHORT_PROPERTIES = (
207 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'],
208 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'],
209 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'],
99870f4d
KW
210 # is also in other alphabetic
211 'Mn' => ['\N{HEBREW POINT RAFE}'],
84281c31
A
212 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'],
213 'Pc' => ["_"],
214 'Po' => ["!"],
215 'Zs' => [" "],
216 'Cc' => ['\x{00}'],
217);
218
219#
220# Illegal properties
221#
d658a8a8
DM
222my @ILLEGAL_PROPERTIES =
223 qw[q qrst f foo isfoo infoo ISfoo INfoo Is::foo In::foo];
84281c31
A
224
225my %d;
226
227while (my ($class, $chars) = each %SHORT_PROPERTIES) {
228 push @{$d {IsAlpha}} => map {$class =~ /^[LM]/ ? $_ : "!$_"} @$chars;
229 push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars;
230 push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}'
231 ? $_ : "!$_"} @$chars;
232 push @{$d {IsCntrl}} => map {$class =~ /^C/ ? $_ : "!$_"} @$chars;
233 push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars;
234 push @{$d {IsDigit}} => map {$class =~ /^Nd$/ ? $_ : "!$_"} @$chars;
235 push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/
236 ? $_ : "!$_"} @$chars;
237 push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/
238 ? $_ : "!$_"} @$chars;
239 push @{$d {IsLower}} => map {$class =~ /^Ll$/ ? $_ : "!$_"} @$chars;
240 push @{$d {IsUpper}} => map {$class =~ /^L[ut]/ ? $_ : "!$_"} @$chars;
241 push @{$d {IsPunct}} => map {$class =~ /^P/ ? $_ : "!$_"} @$chars;
242 push @{$d {IsWord}} => map {$class =~ /^[LMN]/ || $_ eq "_"
243 ? $_ : "!$_"} @$chars;
244 push @{$d {IsSpace}} => map {$class =~ /^Z/ ||
425224e1
KW
245 length ($_) == 1 && utf8::native_to_unicode(ord ($_)) >= 0x09
246 && utf8::native_to_unicode(ord ($_)) <= 0x0D
84281c31
A
247 ? $_ : "!$_"} @$chars;
248}
249
84281c31
A
250push @CLASSES => "# Short properties" => %SHORT_PROPERTIES,
251 "# POSIX like properties" => %d,
327cef2f
KW
252 "# User defined properties" => @USER_DEFINED_PROPERTIES,
253 "# Overriding user defined properties" => @OVERRIDING_USER_DEFINED_PROPERTIES;
84281c31
A
254
255
256#
257# Calculate the number of tests.
258#
259my $count = 0;
260for (my $i = 0; $i < @CLASSES; $i += 2) {
261 $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/;
72d70e56 262 $count += 2 * (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]};
84281c31 263}
72d70e56
NC
264$count += 4 * @ILLEGAL_PROPERTIES;
265$count += 4 * grep {length $_ == 1} @ILLEGAL_PROPERTIES;
266$count += 8 * @USER_CASELESS_PROPERTIES;
3b071fee
KW
267$count += 1 * (@DEFERRED - @USER_ERROR_PROPERTIES) / 2;
268$count += 1 * @USER_ERROR_PROPERTIES;
d82cefba 269$count += 1; # No warnings generated
84281c31 270
72d70e56 271plan(tests => $count);
84281c31
A
272
273run_tests unless caller ();
274
275sub match {
19c4061a
KW
276 my ($char, $match, $nomatch, $caseless) = @_;
277 $caseless = "" unless defined $caseless;
278 $caseless = 'i' if $caseless;
84281c31 279
3a0825d5 280 my ($str, $name) = get_str_name($char);
84281c31 281
19c4061a 282 undef $@;
707250fe
KW
283 my $pat = "qr/$match/$caseless";
284 my $match_pat = eval $pat;
170b30c3
KW
285 if (is($@, '', "$pat compiled correctly to a regexp: $@")) {
286 like($str, $match_pat, "$name correctly matched");
287 }
19c4061a
KW
288
289 undef $@;
707250fe
KW
290 $pat = "qr/$nomatch/$caseless";
291 my $nomatch_pat = eval $pat;
170b30c3
KW
292 if (is($@, '', "$pat compiled correctly to a regexp: $@")) {
293 unlike($str, $nomatch_pat, "$name correctly did not match");
294 }
84281c31
A
295}
296
297sub run_tests {
298
327cef2f 299 for (my $i = 0; $i < @DEFERRED; $i+=2) {
3b071fee 300 if (ref $DEFERRED[$i+1] eq 'ARRAY') {
327cef2f
KW
301 my ($str, $name) = get_str_name($DEFERRED[$i+1][0]);
302 like($str, $DEFERRED[$i],
303 "$name correctly matched $DEFERRED[$i] (defn. not known until runtime)");
3b071fee
KW
304 }
305 else { # Single entry rhs indicates a property that is an error
306 undef $@;
307
308 # Using block eval causes the pattern to not be recompiled, so it
309 # retains its deferred status until this is executed.
310 eval { 'A' =~ $DEFERRED[$i] };
311 like($@, $DEFERRED[$i+1],
312 "$DEFERRED[$i] gave correct failure message (defn. not known until runtime)");
313 }
327cef2f
KW
314 }
315
84281c31
A
316 while (@CLASSES) {
317 my $class = shift @CLASSES;
318 if ($class =~ /^\h*#\h*(.*)/) {
319 print "# $1\n";
320 next;
321 }
322 last unless @CLASSES;
323 my $chars = shift @CLASSES;
324 my @in = grep {!/^!./} @$chars;
325 my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars;
326 my $in_pat = eval qq ['\\p{$class}'];
327 my $out_pat = eval qq ['\\P{$class}'];
328
329 match $_, $in_pat, $out_pat for @in;
330 match $_, $out_pat, $in_pat for @out;
331
9c8ea558 332 if (1 == length $class) { # Repeat without braces if name length 1
84281c31
A
333 my $in_pat = eval qq ['\\p$class'];
334 my $out_pat = eval qq ['\\P$class'];
335
336 match $_, $in_pat, $out_pat for @in;
337 match $_, $out_pat, $in_pat for @out;
338 }
339 }
340
341
84281c31
A
342 print "# Illegal properties\n";
343 foreach my $p (@ILLEGAL_PROPERTIES) {
4003ea29
KW
344 my $pat;
345 if ($p =~ /::/) {
346 $pat = qr /^Illegal user-defined property name/;
347 }
348 else {
349 $pat = qr /^Can't find Unicode property definition/;
350 }
351
84281c31
A
352 undef $@;
353 my $r = eval "'a' =~ /\\p{$p}/; 1";
72d70e56
NC
354 is($r, undef, "Unknown Unicode property \\p{$p}");
355 like($@, $pat, "Unknown Unicode property \\p{$p}");
84281c31
A
356 undef $@;
357 my $s = eval "'a' =~ /\\P{$p}/; 1";
72d70e56
NC
358 is($s, undef, "Unknown Unicode property \\p{$p}");
359 like($@, $pat, "Unknown Unicode property \\p{$p}");
84281c31
A
360 if (length $p == 1) {
361 undef $@;
362 my $r = eval "'a' =~ /\\p$p/; 1";
72d70e56
NC
363 is($r, undef, "Unknown Unicode property \\p$p");
364 like($@, $pat, "Unknown Unicode property \\p$p");
84281c31
A
365 undef $@;
366 my $s = eval "'a' =~ /\\P$p/; 1";
72d70e56
NC
367 is($r, undef, "Unknown Unicode property \\P$p");
368 like($@, $pat, "Unknown Unicode property \\P$p");
84281c31
A
369 }
370 }
19c4061a
KW
371
372 print "# User-defined properties with /i differences\n";
49fdc6e8 373 while (my $class = shift @USER_CASELESS_PROPERTIES) {
19c4061a
KW
374 my $chars_ref = shift @USER_CASELESS_PROPERTIES;
375 my @in = grep {!/^!./} @$chars_ref;
376 my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars_ref;
377 my $in_pat = eval qq ['\\p{$class}'];
378 my $out_pat = eval qq ['\\P{$class}'];
379
1e51e719
KW
380 # Verify that adding /i does change the out set to match.
381 match $_, $in_pat, $out_pat, 'i' for @out;
382
383 # Verify that adding /i doesn't change the in set.
384 match $_, $in_pat, $out_pat, 'i' for @in;
385
19c4061a
KW
386 # Verify works as regularly for not /i
387 match $_, $in_pat, $out_pat for @in;
388 match $_, $out_pat, $in_pat for @out;
3b071fee 389 }
19c4061a 390
3b071fee
KW
391 print "# User-defined properties with errors in their definition\n";
392 while (my $error_property = shift @USER_ERROR_PROPERTIES) {
393 my $error_re = shift @USER_ERROR_PROPERTIES;
19c4061a 394
3b071fee
KW
395 undef $@;
396 eval { 'A' =~ /\p{$error_property}/; };
397 like($@, $error_re, "$error_property gave correct failure message");
19c4061a 398 }
84281c31
A
399}
400
401
402#
403# User defined properties
404#
405
406sub InKana1 {<<'--'}
61ac831b
KW
4073040 309F # A comment; next line has trailing spaces
40830A0 30FF
84281c31
A
409--
410
411sub InKana2 {<<'--'}
412+utf8::InHiragana
413+utf8::InKatakana
414--
415
416sub InKana3 {<<'--'}
61ac831b 417# First line comment
84281c31 418+utf8::InHiragana
61ac831b 419# Full line comment
84281c31
A
420+utf8::InKatakana
421-utf8::IsCn
422--
423
424sub InNotKana {<<'--'}
61ac831b
KW
425!utf8::InHiragana # A comment; next line has trailing spaces
426-utf8::InKatakana
84281c31 427+utf8::IsCn
61ac831b 428# Final line comment
84281c31
A
429--
430
425224e1
KW
431sub InConsonant {
432
433 my $return = "+utf8::Lowercase\n&utf8::ASCII\n";
434 $return .= sprintf("-%X\n", ord "a");
435 $return .= sprintf("-%X\n", ord "e");
436 $return .= sprintf("-%X\n", ord "i");
437 $return .= sprintf("-%X\n", ord "o");
438 $return .= sprintf("-%X\n", ord "u");
439 return $return;
440}
84281c31
A
441
442sub IsSyriac1 {<<'--'}
4430712 072C
4440730 074A
445--
446
3b071fee
KW
447sub InRecursedA {
448 return "+main::InRecursedB\n";
449}
450
451sub InRecursedB {
452 return "+main::InRecursedC\n";
453}
454
455sub InRecursedC {
456 return "+main::InRecursedA\n";
457}
458
84281c31
A
459sub InGreekSmall {return "03B1\t03C9"}
460sub InGreekCapital {return "0391\t03A9\n-03A2"}
461
d658a8a8 462sub IsAsciiHexAndDash {<<'--'}
84281c31
A
463+utf8::ASCII_Hex_Digit
464+utf8::Dash
465--
466
eb765580
KW
467sub InLatin1 {
468 return "0100\t10FFFF";
469}
470
19c4061a 471sub IsMyUpper {
a2fe6cf2
KW
472 use feature 'state';
473
474 state $cased_count = 0;
475 state $caseless_count = 0;
476 my $ret= "+utf8::";
477
19c4061a 478 my $caseless = shift;
a2fe6cf2
KW
479 if($caseless) {
480 die "Called twice" if $caseless_count;
481 $caseless_count++;
482 $ret .= 'Alphabetic'
483 }
484 else {
485 die "Called twice" if $cased_count;
486 $cased_count++;
487 $ret .= 'Uppercase';
488 }
489
490 return $ret . "\n&utf8::ASCII";
19c4061a
KW
491}
492
e4f9f798 493sub pkg1::pkg2::IsMyLower {
3b9fb374
KW
494 my $caseless = shift;
495 return "+utf8::"
496 . (($caseless)
497 ? 'Alphabetic'
498 : 'Lowercase')
499 . "\n&utf8::ASCII";
500}
710d3eb3 501
3b071fee
KW
502sub IsRangeReversed {
503 return "200 100$utf8_comment";
504}
505
506sub IsNonHex {
507 return "BEEF CAGED$utf8_comment";
508}
509
510sub IsDeath {
511 die;
512}
513
8fd2c59a
KW
514# Verify that can use user-defined properties inside another one
515sub IsSyriac1KanaMark {<<'--'}
516+main::IsSyriac1
517+main::InKana3
518&utf8::IsMark
519--
520
d658a8a8
DM
521# fake user-defined properties; these subs shouldn't be called, because
522# their names don't start with In or Is
523
524sub f { die }
525sub foo { die }
526sub isfoo { die }
527sub infoo { die }
528sub ISfoo { die }
529sub INfoo { die }
530sub Is::foo { die }
531sub In::foo { die }
0a441b11 532
3b071fee
KW
533sub IsOverflow {
534 return "0\t$overflow$utf8_comment";
535}
536
d82cefba
KW
537if (! is(@warnings, 0, "No warnings were generated")) {
538 diag join "\n", @warnings, "\n";
539}
540
0a441b11 5411;
84281c31 542__END__