This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
It's an error if any component of \p{user-defined} fails
[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;
6256cf2c 269$count += 1; # one bad apple
d82cefba 270$count += 1; # No warnings generated
84281c31 271
72d70e56 272plan(tests => $count);
84281c31
A
273
274run_tests unless caller ();
275
276sub match {
19c4061a
KW
277 my ($char, $match, $nomatch, $caseless) = @_;
278 $caseless = "" unless defined $caseless;
279 $caseless = 'i' if $caseless;
84281c31 280
3a0825d5 281 my ($str, $name) = get_str_name($char);
84281c31 282
19c4061a 283 undef $@;
707250fe
KW
284 my $pat = "qr/$match/$caseless";
285 my $match_pat = eval $pat;
170b30c3
KW
286 if (is($@, '', "$pat compiled correctly to a regexp: $@")) {
287 like($str, $match_pat, "$name correctly matched");
288 }
19c4061a
KW
289
290 undef $@;
707250fe
KW
291 $pat = "qr/$nomatch/$caseless";
292 my $nomatch_pat = eval $pat;
170b30c3
KW
293 if (is($@, '', "$pat compiled correctly to a regexp: $@")) {
294 unlike($str, $nomatch_pat, "$name correctly did not match");
295 }
84281c31
A
296}
297
298sub run_tests {
299
327cef2f 300 for (my $i = 0; $i < @DEFERRED; $i+=2) {
3b071fee 301 if (ref $DEFERRED[$i+1] eq 'ARRAY') {
327cef2f
KW
302 my ($str, $name) = get_str_name($DEFERRED[$i+1][0]);
303 like($str, $DEFERRED[$i],
304 "$name correctly matched $DEFERRED[$i] (defn. not known until runtime)");
3b071fee
KW
305 }
306 else { # Single entry rhs indicates a property that is an error
307 undef $@;
308
309 # Using block eval causes the pattern to not be recompiled, so it
310 # retains its deferred status until this is executed.
311 eval { 'A' =~ $DEFERRED[$i] };
312 like($@, $DEFERRED[$i+1],
313 "$DEFERRED[$i] gave correct failure message (defn. not known until runtime)");
314 }
327cef2f
KW
315 }
316
84281c31
A
317 while (@CLASSES) {
318 my $class = shift @CLASSES;
319 if ($class =~ /^\h*#\h*(.*)/) {
320 print "# $1\n";
321 next;
322 }
323 last unless @CLASSES;
324 my $chars = shift @CLASSES;
325 my @in = grep {!/^!./} @$chars;
326 my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars;
327 my $in_pat = eval qq ['\\p{$class}'];
328 my $out_pat = eval qq ['\\P{$class}'];
329
330 match $_, $in_pat, $out_pat for @in;
331 match $_, $out_pat, $in_pat for @out;
332
9c8ea558 333 if (1 == length $class) { # Repeat without braces if name length 1
84281c31
A
334 my $in_pat = eval qq ['\\p$class'];
335 my $out_pat = eval qq ['\\P$class'];
336
337 match $_, $in_pat, $out_pat for @in;
338 match $_, $out_pat, $in_pat for @out;
339 }
340 }
341
342
84281c31
A
343 print "# Illegal properties\n";
344 foreach my $p (@ILLEGAL_PROPERTIES) {
4003ea29
KW
345 my $pat;
346 if ($p =~ /::/) {
347 $pat = qr /^Illegal user-defined property name/;
348 }
349 else {
350 $pat = qr /^Can't find Unicode property definition/;
351 }
352
84281c31
A
353 undef $@;
354 my $r = eval "'a' =~ /\\p{$p}/; 1";
72d70e56
NC
355 is($r, undef, "Unknown Unicode property \\p{$p}");
356 like($@, $pat, "Unknown Unicode property \\p{$p}");
84281c31
A
357 undef $@;
358 my $s = eval "'a' =~ /\\P{$p}/; 1";
72d70e56
NC
359 is($s, undef, "Unknown Unicode property \\p{$p}");
360 like($@, $pat, "Unknown Unicode property \\p{$p}");
84281c31
A
361 if (length $p == 1) {
362 undef $@;
363 my $r = eval "'a' =~ /\\p$p/; 1";
72d70e56
NC
364 is($r, undef, "Unknown Unicode property \\p$p");
365 like($@, $pat, "Unknown Unicode property \\p$p");
84281c31
A
366 undef $@;
367 my $s = eval "'a' =~ /\\P$p/; 1";
72d70e56
NC
368 is($r, undef, "Unknown Unicode property \\P$p");
369 like($@, $pat, "Unknown Unicode property \\P$p");
84281c31
A
370 }
371 }
19c4061a
KW
372
373 print "# User-defined properties with /i differences\n";
49fdc6e8 374 while (my $class = shift @USER_CASELESS_PROPERTIES) {
19c4061a
KW
375 my $chars_ref = shift @USER_CASELESS_PROPERTIES;
376 my @in = grep {!/^!./} @$chars_ref;
377 my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars_ref;
378 my $in_pat = eval qq ['\\p{$class}'];
379 my $out_pat = eval qq ['\\P{$class}'];
380
1e51e719
KW
381 # Verify that adding /i does change the out set to match.
382 match $_, $in_pat, $out_pat, 'i' for @out;
383
384 # Verify that adding /i doesn't change the in set.
385 match $_, $in_pat, $out_pat, 'i' for @in;
386
19c4061a
KW
387 # Verify works as regularly for not /i
388 match $_, $in_pat, $out_pat for @in;
389 match $_, $out_pat, $in_pat for @out;
3b071fee 390 }
19c4061a 391
3b071fee
KW
392 print "# User-defined properties with errors in their definition\n";
393 while (my $error_property = shift @USER_ERROR_PROPERTIES) {
394 my $error_re = shift @USER_ERROR_PROPERTIES;
19c4061a 395
3b071fee
KW
396 undef $@;
397 eval { 'A' =~ /\p{$error_property}/; };
398 like($@, $error_re, "$error_property gave correct failure message");
19c4061a 399 }
84281c31
A
400}
401
402
403#
404# User defined properties
405#
406
407sub InKana1 {<<'--'}
61ac831b
KW
4083040 309F # A comment; next line has trailing spaces
40930A0 30FF
84281c31
A
410--
411
412sub InKana2 {<<'--'}
413+utf8::InHiragana
414+utf8::InKatakana
415--
416
417sub InKana3 {<<'--'}
61ac831b 418# First line comment
84281c31 419+utf8::InHiragana
61ac831b 420# Full line comment
84281c31
A
421+utf8::InKatakana
422-utf8::IsCn
423--
424
425sub InNotKana {<<'--'}
61ac831b
KW
426!utf8::InHiragana # A comment; next line has trailing spaces
427-utf8::InKatakana
84281c31 428+utf8::IsCn
61ac831b 429# Final line comment
84281c31
A
430--
431
425224e1
KW
432sub InConsonant {
433
434 my $return = "+utf8::Lowercase\n&utf8::ASCII\n";
435 $return .= sprintf("-%X\n", ord "a");
436 $return .= sprintf("-%X\n", ord "e");
437 $return .= sprintf("-%X\n", ord "i");
438 $return .= sprintf("-%X\n", ord "o");
439 $return .= sprintf("-%X\n", ord "u");
440 return $return;
441}
84281c31
A
442
443sub IsSyriac1 {<<'--'}
4440712 072C
4450730 074A
446--
447
3b071fee
KW
448sub InRecursedA {
449 return "+main::InRecursedB\n";
450}
451
452sub InRecursedB {
453 return "+main::InRecursedC\n";
454}
455
456sub InRecursedC {
457 return "+main::InRecursedA\n";
458}
459
84281c31
A
460sub InGreekSmall {return "03B1\t03C9"}
461sub InGreekCapital {return "0391\t03A9\n-03A2"}
462
d658a8a8 463sub IsAsciiHexAndDash {<<'--'}
84281c31
A
464+utf8::ASCII_Hex_Digit
465+utf8::Dash
466--
467
eb765580
KW
468sub InLatin1 {
469 return "0100\t10FFFF";
470}
471
19c4061a 472sub IsMyUpper {
a2fe6cf2
KW
473 use feature 'state';
474
475 state $cased_count = 0;
476 state $caseless_count = 0;
477 my $ret= "+utf8::";
478
19c4061a 479 my $caseless = shift;
a2fe6cf2
KW
480 if($caseless) {
481 die "Called twice" if $caseless_count;
482 $caseless_count++;
483 $ret .= 'Alphabetic'
484 }
485 else {
486 die "Called twice" if $cased_count;
487 $cased_count++;
488 $ret .= 'Uppercase';
489 }
490
491 return $ret . "\n&utf8::ASCII";
19c4061a
KW
492}
493
e4f9f798 494sub pkg1::pkg2::IsMyLower {
3b9fb374
KW
495 my $caseless = shift;
496 return "+utf8::"
497 . (($caseless)
498 ? 'Alphabetic'
499 : 'Lowercase')
500 . "\n&utf8::ASCII";
501}
710d3eb3 502
3b071fee
KW
503sub IsRangeReversed {
504 return "200 100$utf8_comment";
505}
506
507sub IsNonHex {
508 return "BEEF CAGED$utf8_comment";
509}
510
511sub IsDeath {
512 die;
513}
514
8fd2c59a
KW
515# Verify that can use user-defined properties inside another one
516sub IsSyriac1KanaMark {<<'--'}
517+main::IsSyriac1
518+main::InKana3
519&utf8::IsMark
520--
521
d658a8a8
DM
522# fake user-defined properties; these subs shouldn't be called, because
523# their names don't start with In or Is
524
525sub f { die }
526sub foo { die }
527sub isfoo { die }
528sub infoo { die }
529sub ISfoo { die }
530sub INfoo { die }
531sub Is::foo { die }
532sub In::foo { die }
0a441b11 533
3b071fee
KW
534sub IsOverflow {
535 return "0\t$overflow$utf8_comment";
536}
537
6256cf2c
KW
538fresh_perl_like(<<'EOP', qr/Can't find Unicode property definition "F000\\tF010" in expansion of InOneBadApple/, {}, "Just one component bad");
539# Extra backslash converts tab to backslash-t
540sub InOneBadApple { return "0100\t0110\n10000\t10010\nF000\\tF010\n0400\t0410" }
541qr/\p{InOneBadApple}/;
542EOP
543
d82cefba
KW
544if (! is(@warnings, 0, "No warnings were generated")) {
545 diag join "\n", @warnings, "\n";
546}
547
0a441b11 5481;
84281c31 549__END__