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.
11 my $IS_EBCDIC = ord ('A') == 193;
16 # This is the data to test.
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
26 # If a character entry starts with ! the character does not belong to the class
28 # If the class is just single letter, we use both \pL and \p{L}
31 use charnames ':full';
41 'Lowercase Letter' => ["h", "!H"],
43 Common => ["!i", "3"],
44 Inherited => ["!j", '\x{300}'],
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}'],
61 # It's ok to repeat class names.
64 $IS_EBCDIC ? ['!\x{7f}', '\x{80}', '!\x{100}']
65 : ['!\x{7f}', '\x{80}', '\x{ff}', '!\x{100}'],
67 ['!\x{7f}', '!\x{80}', '!\x{ff}', '\x{100}'],
70 # Properties are case-insensitive, and may have whitespace,
71 # dashes and underscores.
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"],
81 my @USER_DEFINED_PROPERTIES = (
83 # User defined properties
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}'],
91 Syriac1 => ['\x{0712}', '!\x{072F}'],
92 '# User-defined character properties my lack \n at the end',
93 InGreekSmall => ['\N{GREEK SMALL LETTER PI}',
94 '\N{GREEK SMALL LETTER FINAL SIGMA}'],
95 InGreekCapital => ['\N{GREEK CAPITAL LETTER PI}', '!\x{03A2}'],
97 ASCII_Hex_Digit => ['!-', 'A'],
98 AsciiHexAndDash => ['-', 'A'],
103 # From the short properties we populate POSIX-like classes.
105 my %SHORT_PROPERTIES = (
106 'Ll' => ['m', '\N{CYRILLIC SMALL LETTER A}'],
107 'Lu' => ['M', '\N{GREEK CAPITAL LETTER ALPHA}'],
108 'Lo' => ['\N{HIRAGANA LETTER SMALL A}'],
109 # is also in other alphabetic
110 'Mn' => ['\N{HEBREW POINT RAFE}'],
111 'Nd' => ["0", '\N{ARABIC-INDIC DIGIT ZERO}'],
121 my @ILLEGAL_PROPERTIES = qw [q qrst];
125 while (my ($class, $chars) = each %SHORT_PROPERTIES) {
126 push @{$d {IsAlpha}} => map {$class =~ /^[LM]/ ? $_ : "!$_"} @$chars;
127 push @{$d {IsAlnum}} => map {$class =~ /^[LMN]./ ? $_ : "!$_"} @$chars;
128 push @{$d {IsASCII}} => map {length ($_) == 1 || $_ eq '\x{00}'
129 ? $_ : "!$_"} @$chars;
130 push @{$d {IsCntrl}} => map {$class =~ /^C/ ? $_ : "!$_"} @$chars;
131 push @{$d {IsBlank}} => map {$class =~ /^Z[lps]/ ? $_ : "!$_"} @$chars;
132 push @{$d {IsDigit}} => map {$class =~ /^Nd$/ ? $_ : "!$_"} @$chars;
133 push @{$d {IsGraph}} => map {$class =~ /^([LMNPS]|Co)/
134 ? $_ : "!$_"} @$chars;
135 push @{$d {IsPrint}} => map {$class =~ /^([LMNPS]|Co|Zs)/
136 ? $_ : "!$_"} @$chars;
137 push @{$d {IsLower}} => map {$class =~ /^Ll$/ ? $_ : "!$_"} @$chars;
138 push @{$d {IsUpper}} => map {$class =~ /^L[ut]/ ? $_ : "!$_"} @$chars;
139 push @{$d {IsPunct}} => map {$class =~ /^P/ ? $_ : "!$_"} @$chars;
140 push @{$d {IsWord}} => map {$class =~ /^[LMN]/ || $_ eq "_"
141 ? $_ : "!$_"} @$chars;
142 push @{$d {IsSpace}} => map {$class =~ /^Z/ ||
143 length ($_) == 1 && ord ($_) >= 0x09
145 ? $_ : "!$_"} @$chars;
148 delete $d {IsASCII} if $IS_EBCDIC;
150 push @CLASSES => "# Short properties" => %SHORT_PROPERTIES,
151 "# POSIX like properties" => %d,
152 "# User defined properties" => @USER_DEFINED_PROPERTIES;
156 # Calculate the number of tests.
159 for (my $i = 0; $i < @CLASSES; $i += 2) {
160 $i ++, redo if $CLASSES [$i] =~ /^\h*#\h*(.*)/;
161 $count += (length $CLASSES [$i] == 1 ? 4 : 2) * @{$CLASSES [$i + 1]};
163 $count += 2 * @ILLEGAL_PROPERTIES;
164 $count += 2 * grep {length $_ == 1} @ILLEGAL_PROPERTIES;
170 run_tests unless caller ();
173 my ($char, $match, $nomatch) = @_;
179 $str = eval qq ["$char"];
180 $name = qq ["$char"];
182 when (/^0x([0-9A-Fa-f]+)$/) {
184 $name = "chr ($char)";
188 $name = qq ["$char"];
192 print "not " unless $str =~ /$match/;
193 print "ok ", ++ $tests, " - $name =~ /$match/\n";
194 print "not " unless $str !~ /$nomatch/;
195 print "ok ", ++ $tests, " - $name !~ /$nomatch/\n";
201 my $class = shift @CLASSES;
202 if ($class =~ /^\h*#\h*(.*)/) {
206 last unless @CLASSES;
207 my $chars = shift @CLASSES;
208 my @in = grep {!/^!./} @$chars;
209 my @out = map {s/^!(?=.)//; $_} grep { /^!./} @$chars;
210 my $in_pat = eval qq ['\\p{$class}'];
211 my $out_pat = eval qq ['\\P{$class}'];
213 match $_, $in_pat, $out_pat for @in;
214 match $_, $out_pat, $in_pat for @out;
216 if (1 == length $class) {
217 my $in_pat = eval qq ['\\p$class'];
218 my $out_pat = eval qq ['\\P$class'];
220 match $_, $in_pat, $out_pat for @in;
221 match $_, $out_pat, $in_pat for @out;
226 my $pat = qr /^Can't find Unicode property definition/;
227 print "# Illegal properties\n";
228 foreach my $p (@ILLEGAL_PROPERTIES) {
230 my $r = eval "'a' =~ /\\p{$p}/; 1";
231 print "not " unless !$r && $@ && $@ =~ $pat;
232 print "ok ", ++ $tests, " - Unknown Unicode property \\p{$p}\n";
234 my $s = eval "'a' =~ /\\P{$p}/; 1";
235 print "not " unless !$s && $@ && $@ =~ $pat;
236 print "ok ", ++ $tests, " - Unknown Unicode property \\P{$p}\n";
237 if (length $p == 1) {
239 my $r = eval "'a' =~ /\\p$p/; 1";
240 print "not " unless !$r && $@ && $@ =~ $pat;
241 print "ok ", ++ $tests, " - Unknown Unicode property \\p$p\n";
243 my $s = eval "'a' =~ /\\P$p/; 1";
244 print "not " unless !$s && $@ && $@ =~ $pat;
245 print "ok ", ++ $tests, " - Unknown Unicode property \\P$p\n";
252 # User defined properties
271 sub InNotKana {<<'--'}
277 sub InConsonant {<<'--'} # Not EBCDIC-aware.
286 sub IsSyriac1 {<<'--'}
296 sub InGreekSmall {return "03B1\t03C9"}
297 sub InGreekCapital {return "0391\t03A9\n-03A2"}
299 sub AsciiHexAndDash {<<'--'}
300 +utf8::ASCII_Hex_Digit