4 print "1..0 # Skip: EBCDIC\n";
9 require Config; import Config;
10 if ($Config{'extensions'} !~ /\bStorable\b/) {
11 print "1..0 # Skip: Storable was not built; Unicode::UCD uses Storable\n";
20 use Unicode::UCD 'charinfo';
22 my $input_record_separator = 7; # Make sure Unicode::UCD isn't affected by
23 $/ = $input_record_separator; # setting this.
27 is(charinfo(0x110000), undef, "Verify charinfo() of non-unicode is undef");
29 $charinfo = charinfo(0); # Null is often problematic, so test it.
31 is($charinfo->{code}, '0000', '<control>');
32 is($charinfo->{name}, '<control>');
33 is($charinfo->{category}, 'Cc');
34 is($charinfo->{combining}, '0');
35 is($charinfo->{bidi}, 'BN');
36 is($charinfo->{decomposition}, '');
37 is($charinfo->{decimal}, '');
38 is($charinfo->{digit}, '');
39 is($charinfo->{numeric}, '');
40 is($charinfo->{mirrored}, 'N');
41 is($charinfo->{unicode10}, 'NULL');
42 is($charinfo->{comment}, '');
43 is($charinfo->{upper}, '');
44 is($charinfo->{lower}, '');
45 is($charinfo->{title}, '');
46 is($charinfo->{block}, 'Basic Latin');
47 is($charinfo->{script}, 'Common');
49 $charinfo = charinfo(0x41);
51 is($charinfo->{code}, '0041', 'LATIN CAPITAL LETTER A');
52 is($charinfo->{name}, 'LATIN CAPITAL LETTER A');
53 is($charinfo->{category}, 'Lu');
54 is($charinfo->{combining}, '0');
55 is($charinfo->{bidi}, 'L');
56 is($charinfo->{decomposition}, '');
57 is($charinfo->{decimal}, '');
58 is($charinfo->{digit}, '');
59 is($charinfo->{numeric}, '');
60 is($charinfo->{mirrored}, 'N');
61 is($charinfo->{unicode10}, '');
62 is($charinfo->{comment}, '');
63 is($charinfo->{upper}, '');
64 is($charinfo->{lower}, '0061');
65 is($charinfo->{title}, '');
66 is($charinfo->{block}, 'Basic Latin');
67 is($charinfo->{script}, 'Latin');
69 $charinfo = charinfo(0x100);
71 is($charinfo->{code}, '0100', 'LATIN CAPITAL LETTER A WITH MACRON');
72 is($charinfo->{name}, 'LATIN CAPITAL LETTER A WITH MACRON');
73 is($charinfo->{category}, 'Lu');
74 is($charinfo->{combining}, '0');
75 is($charinfo->{bidi}, 'L');
76 is($charinfo->{decomposition}, '0041 0304');
77 is($charinfo->{decimal}, '');
78 is($charinfo->{digit}, '');
79 is($charinfo->{numeric}, '');
80 is($charinfo->{mirrored}, 'N');
81 is($charinfo->{unicode10}, 'LATIN CAPITAL LETTER A MACRON');
82 is($charinfo->{comment}, '');
83 is($charinfo->{upper}, '');
84 is($charinfo->{lower}, '0101');
85 is($charinfo->{title}, '');
86 is($charinfo->{block}, 'Latin Extended-A');
87 is($charinfo->{script}, 'Latin');
89 # 0x0590 is in the Hebrew block but unused.
91 $charinfo = charinfo(0x590);
93 is($charinfo->{code}, undef, '0x0590 - unused Hebrew');
94 is($charinfo->{name}, undef);
95 is($charinfo->{category}, undef);
96 is($charinfo->{combining}, undef);
97 is($charinfo->{bidi}, undef);
98 is($charinfo->{decomposition}, undef);
99 is($charinfo->{decimal}, undef);
100 is($charinfo->{digit}, undef);
101 is($charinfo->{numeric}, undef);
102 is($charinfo->{mirrored}, undef);
103 is($charinfo->{unicode10}, undef);
104 is($charinfo->{comment}, undef);
105 is($charinfo->{upper}, undef);
106 is($charinfo->{lower}, undef);
107 is($charinfo->{title}, undef);
108 is($charinfo->{block}, undef);
109 is($charinfo->{script}, undef);
111 # 0x05d0 is in the Hebrew block and used.
113 $charinfo = charinfo(0x5d0);
115 is($charinfo->{code}, '05D0', '05D0 - used Hebrew');
116 is($charinfo->{name}, 'HEBREW LETTER ALEF');
117 is($charinfo->{category}, 'Lo');
118 is($charinfo->{combining}, '0');
119 is($charinfo->{bidi}, 'R');
120 is($charinfo->{decomposition}, '');
121 is($charinfo->{decimal}, '');
122 is($charinfo->{digit}, '');
123 is($charinfo->{numeric}, '');
124 is($charinfo->{mirrored}, 'N');
125 is($charinfo->{unicode10}, '');
126 is($charinfo->{comment}, '');
127 is($charinfo->{upper}, '');
128 is($charinfo->{lower}, '');
129 is($charinfo->{title}, '');
130 is($charinfo->{block}, 'Hebrew');
131 is($charinfo->{script}, 'Hebrew');
133 # An open syllable in Hangul.
135 $charinfo = charinfo(0xAC00);
137 is($charinfo->{code}, 'AC00', 'HANGUL SYLLABLE U+AC00');
138 is($charinfo->{name}, 'HANGUL SYLLABLE GA');
139 is($charinfo->{category}, 'Lo');
140 is($charinfo->{combining}, '0');
141 is($charinfo->{bidi}, 'L');
142 is($charinfo->{decomposition}, '1100 1161');
143 is($charinfo->{decimal}, '');
144 is($charinfo->{digit}, '');
145 is($charinfo->{numeric}, '');
146 is($charinfo->{mirrored}, 'N');
147 is($charinfo->{unicode10}, '');
148 is($charinfo->{comment}, '');
149 is($charinfo->{upper}, '');
150 is($charinfo->{lower}, '');
151 is($charinfo->{title}, '');
152 is($charinfo->{block}, 'Hangul Syllables');
153 is($charinfo->{script}, 'Hangul');
155 # A closed syllable in Hangul.
157 $charinfo = charinfo(0xAE00);
159 is($charinfo->{code}, 'AE00', 'HANGUL SYLLABLE U+AE00');
160 is($charinfo->{name}, 'HANGUL SYLLABLE GEUL');
161 is($charinfo->{category}, 'Lo');
162 is($charinfo->{combining}, '0');
163 is($charinfo->{bidi}, 'L');
164 is($charinfo->{decomposition}, "1100 1173 11AF");
165 is($charinfo->{decimal}, '');
166 is($charinfo->{digit}, '');
167 is($charinfo->{numeric}, '');
168 is($charinfo->{mirrored}, 'N');
169 is($charinfo->{unicode10}, '');
170 is($charinfo->{comment}, '');
171 is($charinfo->{upper}, '');
172 is($charinfo->{lower}, '');
173 is($charinfo->{title}, '');
174 is($charinfo->{block}, 'Hangul Syllables');
175 is($charinfo->{script}, 'Hangul');
177 $charinfo = charinfo(0x1D400);
179 is($charinfo->{code}, '1D400', 'MATHEMATICAL BOLD CAPITAL A');
180 is($charinfo->{name}, 'MATHEMATICAL BOLD CAPITAL A');
181 is($charinfo->{category}, 'Lu');
182 is($charinfo->{combining}, '0');
183 is($charinfo->{bidi}, 'L');
184 is($charinfo->{decomposition}, '<font> 0041');
185 is($charinfo->{decimal}, '');
186 is($charinfo->{digit}, '');
187 is($charinfo->{numeric}, '');
188 is($charinfo->{mirrored}, 'N');
189 is($charinfo->{unicode10}, '');
190 is($charinfo->{comment}, '');
191 is($charinfo->{upper}, '');
192 is($charinfo->{lower}, '');
193 is($charinfo->{title}, '');
194 is($charinfo->{block}, 'Mathematical Alphanumeric Symbols');
195 is($charinfo->{script}, 'Common');
197 $charinfo = charinfo(0x9FBA); #Bug 58428
199 is($charinfo->{code}, '9FBA', 'U+9FBA');
200 is($charinfo->{name}, 'CJK UNIFIED IDEOGRAPH-9FBA');
201 is($charinfo->{category}, 'Lo');
202 is($charinfo->{combining}, '0');
203 is($charinfo->{bidi}, 'L');
204 is($charinfo->{decomposition}, '');
205 is($charinfo->{decimal}, '');
206 is($charinfo->{digit}, '');
207 is($charinfo->{numeric}, '');
208 is($charinfo->{mirrored}, 'N');
209 is($charinfo->{unicode10}, '');
210 is($charinfo->{comment}, '');
211 is($charinfo->{upper}, '');
212 is($charinfo->{lower}, '');
213 is($charinfo->{title}, '');
214 is($charinfo->{block}, 'CJK Unified Ideographs');
215 is($charinfo->{script}, 'Han');
217 use Unicode::UCD qw(charblock charscript);
219 # 0x0590 is in the Hebrew block but unused.
221 is(charblock(0x590), 'Hebrew', '0x0590 - Hebrew unused charblock');
222 is(charscript(0x590), 'Unknown', '0x0590 - Hebrew unused charscript');
223 is(charblock(0x1FFFF), 'No_Block', '0x1FFFF - unused charblock');
225 $charinfo = charinfo(0xbe);
227 is($charinfo->{code}, '00BE', 'VULGAR FRACTION THREE QUARTERS');
228 is($charinfo->{name}, 'VULGAR FRACTION THREE QUARTERS');
229 is($charinfo->{category}, 'No');
230 is($charinfo->{combining}, '0');
231 is($charinfo->{bidi}, 'ON');
232 is($charinfo->{decomposition}, '<fraction> 0033 2044 0034');
233 is($charinfo->{decimal}, '');
234 is($charinfo->{digit}, '');
235 is($charinfo->{numeric}, '3/4');
236 is($charinfo->{mirrored}, 'N');
237 is($charinfo->{unicode10}, 'FRACTION THREE QUARTERS');
238 is($charinfo->{comment}, '');
239 is($charinfo->{upper}, '');
240 is($charinfo->{lower}, '');
241 is($charinfo->{title}, '');
242 is($charinfo->{block}, 'Latin-1 Supplement');
243 is($charinfo->{script}, 'Common');
245 # This is to test a case where both simple and full lowercases exist and
247 $charinfo = charinfo(0x130);
249 is($charinfo->{code}, '0130', 'LATIN CAPITAL LETTER I WITH DOT ABOVE');
250 is($charinfo->{name}, 'LATIN CAPITAL LETTER I WITH DOT ABOVE');
251 is($charinfo->{category}, 'Lu');
252 is($charinfo->{combining}, '0');
253 is($charinfo->{bidi}, 'L');
254 is($charinfo->{decomposition}, '0049 0307');
255 is($charinfo->{decimal}, '');
256 is($charinfo->{digit}, '');
257 is($charinfo->{numeric}, '');
258 is($charinfo->{mirrored}, 'N');
259 is($charinfo->{unicode10}, 'LATIN CAPITAL LETTER I DOT');
260 is($charinfo->{comment}, '');
261 is($charinfo->{upper}, '');
262 is($charinfo->{lower}, '0069');
263 is($charinfo->{title}, '');
264 is($charinfo->{block}, 'Latin Extended-A');
265 is($charinfo->{script}, 'Latin');
267 # This is to test a case where both simple and full uppercases exist and
269 $charinfo = charinfo(0x1F80);
271 is($charinfo->{code}, '1F80', 'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
272 is($charinfo->{name}, 'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
273 is($charinfo->{category}, 'Ll');
274 is($charinfo->{combining}, '0');
275 is($charinfo->{bidi}, 'L');
276 is($charinfo->{decomposition}, '1F00 0345');
277 is($charinfo->{decimal}, '');
278 is($charinfo->{digit}, '');
279 is($charinfo->{numeric}, '');
280 is($charinfo->{mirrored}, 'N');
281 is($charinfo->{unicode10}, '');
282 is($charinfo->{comment}, '');
283 is($charinfo->{upper}, '1F88');
284 is($charinfo->{lower}, '');
285 is($charinfo->{title}, '1F88');
286 is($charinfo->{block}, 'Greek Extended');
287 is($charinfo->{script}, 'Greek');
289 use Unicode::UCD qw(charblocks charscripts);
291 my $charblocks = charblocks();
293 ok(exists $charblocks->{Thai}, 'Thai charblock exists');
294 is($charblocks->{Thai}->[0]->[0], hex('0e00'));
295 ok(!exists $charblocks->{PigLatin}, 'PigLatin charblock does not exist');
297 my $charscripts = charscripts();
299 ok(exists $charscripts->{Armenian}, 'Armenian charscript exists');
300 is($charscripts->{Armenian}->[0]->[0], hex('0531'));
301 ok(!exists $charscripts->{PigLatin}, 'PigLatin charscript does not exist');
305 $charscript = charscript("12ab");
306 is($charscript, 'Ethiopic', 'Ethiopic charscript');
308 $charscript = charscript("0x12ab");
309 is($charscript, 'Ethiopic');
311 $charscript = charscript("U+12ab");
312 is($charscript, 'Ethiopic');
316 $ranges = charscript('Ogham');
317 is($ranges->[0]->[0], hex('1680'), 'Ogham charscript');
318 is($ranges->[0]->[1], hex('169C'));
320 use Unicode::UCD qw(charinrange);
322 $ranges = charscript('Cherokee');
323 ok(!charinrange($ranges, "139f"), 'Cherokee charscript');
324 ok( charinrange($ranges, "13a0"));
325 ok( charinrange($ranges, "13f4"));
326 ok(!charinrange($ranges, "13f5"));
328 use Unicode::UCD qw(general_categories);
330 my $gc = general_categories();
332 ok(exists $gc->{L}, 'has L');
333 is($gc->{L}, 'Letter', 'L is Letter');
334 is($gc->{Lu}, 'UppercaseLetter', 'Lu is UppercaseLetter');
336 use Unicode::UCD qw(bidi_types);
338 my $bt = bidi_types();
340 ok(exists $bt->{L}, 'has L');
341 is($bt->{L}, 'Left-to-Right', 'L is Left-to-Right');
342 is($bt->{AL}, 'Right-to-Left Arabic', 'AL is Right-to-Left Arabic');
344 # If this fails, then maybe one should look at the Unicode changes to see
345 # what else might need to be updated.
346 is(Unicode::UCD::UnicodeVersion, '6.3.0', 'UnicodeVersion');
348 use Unicode::UCD qw(compexcl);
350 ok(!compexcl(0x0100), 'compexcl');
351 ok(!compexcl(0xD801), 'compexcl of surrogate');
352 ok(!compexcl(0x110000), 'compexcl of non-Unicode code point');
353 ok( compexcl(0x0958));
355 use Unicode::UCD qw(casefold);
359 $casefold = casefold(0x41);
361 is($casefold->{code}, '0041', 'casefold 0x41 code');
362 is($casefold->{status}, 'C', 'casefold 0x41 status');
363 is($casefold->{mapping}, '0061', 'casefold 0x41 mapping');
364 is($casefold->{full}, '0061', 'casefold 0x41 full');
365 is($casefold->{simple}, '0061', 'casefold 0x41 simple');
366 is($casefold->{turkic}, "", 'casefold 0x41 turkic');
368 $casefold = casefold(0xdf);
370 is($casefold->{code}, '00DF', 'casefold 0xDF code');
371 is($casefold->{status}, 'F', 'casefold 0xDF status');
372 is($casefold->{mapping}, '0073 0073', 'casefold 0xDF mapping');
373 is($casefold->{full}, '0073 0073', 'casefold 0xDF full');
374 is($casefold->{simple}, "", 'casefold 0xDF simple');
375 is($casefold->{turkic}, "", 'casefold 0xDF turkic');
377 # Do different tests depending on if version < 3.2, or not.
378 my $v_unicode_version = pack "C*", split /\./, Unicode::UCD::UnicodeVersion();
379 if ($v_unicode_version lt v3.2.0) {
380 $casefold = casefold(0x130);
382 is($casefold->{code}, '0130', 'casefold 0x130 code');
383 is($casefold->{status}, 'I' , 'casefold 0x130 status');
384 is($casefold->{mapping}, '0069', 'casefold 0x130 mapping');
385 is($casefold->{full}, '0069', 'casefold 0x130 full');
386 is($casefold->{simple}, "0069", 'casefold 0x130 simple');
387 is($casefold->{turkic}, "0069", 'casefold 0x130 turkic');
389 $casefold = casefold(0x131);
391 is($casefold->{code}, '0131', 'casefold 0x131 code');
392 is($casefold->{status}, 'I' , 'casefold 0x131 status');
393 is($casefold->{mapping}, '0069', 'casefold 0x131 mapping');
394 is($casefold->{full}, '0069', 'casefold 0x131 full');
395 is($casefold->{simple}, "0069", 'casefold 0x131 simple');
396 is($casefold->{turkic}, "0069", 'casefold 0x131 turkic');
398 $casefold = casefold(0x49);
400 is($casefold->{code}, '0049', 'casefold 0x49 code');
401 is($casefold->{status}, 'C' , 'casefold 0x49 status');
402 is($casefold->{mapping}, '0069', 'casefold 0x49 mapping');
403 is($casefold->{full}, '0069', 'casefold 0x49 full');
404 is($casefold->{simple}, "0069", 'casefold 0x49 simple');
405 is($casefold->{turkic}, "0131", 'casefold 0x49 turkic');
407 $casefold = casefold(0x130);
409 is($casefold->{code}, '0130', 'casefold 0x130 code');
410 is($casefold->{status}, 'F' , 'casefold 0x130 status');
411 is($casefold->{mapping}, '0069 0307', 'casefold 0x130 mapping');
412 is($casefold->{full}, '0069 0307', 'casefold 0x130 full');
413 is($casefold->{simple}, "", 'casefold 0x130 simple');
414 is($casefold->{turkic}, "0069", 'casefold 0x130 turkic');
417 $casefold = casefold(0x1F88);
419 is($casefold->{code}, '1F88', 'casefold 0x1F88 code');
420 is($casefold->{status}, 'S' , 'casefold 0x1F88 status');
421 is($casefold->{mapping}, '1F80', 'casefold 0x1F88 mapping');
422 is($casefold->{full}, '1F00 03B9', 'casefold 0x1F88 full');
423 is($casefold->{simple}, '1F80', 'casefold 0x1F88 simple');
424 is($casefold->{turkic}, "", 'casefold 0x1F88 turkic');
428 use Unicode::UCD qw(casespec);
434 $casespec = casespec(0xdf);
436 ok($casespec->{code} eq '00DF' &&
437 $casespec->{lower} eq '00DF' &&
438 $casespec->{title} eq '0053 0073' &&
439 $casespec->{upper} eq '0053 0053' &&
440 !defined $casespec->{condition}, 'casespec 0xDF');
442 $casespec = casespec(0x307);
444 ok($casespec->{az}->{code} eq '0307' &&
445 !defined $casespec->{az}->{lower} &&
446 $casespec->{az}->{title} eq '0307' &&
447 $casespec->{az}->{upper} eq '0307' &&
448 $casespec->{az}->{condition} eq 'az After_I',
451 # perl #7305 UnicodeCD::compexcl is weird
453 for (1) {my $a=compexcl $_}
454 ok(1, 'compexcl read-only $_: perl #7305');
455 map {compexcl $_} %{{1=>2}};
456 ok(1, 'compexcl read-only hash: perl #7305');
458 is(Unicode::UCD::_getcode('123'), 123, "_getcode(123)");
459 is(Unicode::UCD::_getcode('0123'), 0x123, "_getcode(0123)");
460 is(Unicode::UCD::_getcode('0x123'), 0x123, "_getcode(0x123)");
461 is(Unicode::UCD::_getcode('0X123'), 0x123, "_getcode(0X123)");
462 is(Unicode::UCD::_getcode('U+123'), 0x123, "_getcode(U+123)");
463 is(Unicode::UCD::_getcode('u+123'), 0x123, "_getcode(u+123)");
464 is(Unicode::UCD::_getcode('U+1234'), 0x1234, "_getcode(U+1234)");
465 is(Unicode::UCD::_getcode('U+12345'), 0x12345, "_getcode(U+12345)");
466 is(Unicode::UCD::_getcode('123x'), undef, "_getcode(123x)");
467 is(Unicode::UCD::_getcode('x123'), undef, "_getcode(x123)");
468 is(Unicode::UCD::_getcode('0x123x'), undef, "_getcode(x123)");
469 is(Unicode::UCD::_getcode('U+123x'), undef, "_getcode(x123)");
472 my $r1 = charscript('Latin');
473 if (ok(defined $r1, "Found Latin script")) {
475 is($n1, 30, "number of ranges in Latin script (Unicode 6.1.0)");
476 shift @$r1 while @$r1;
477 my $r2 = charscript('Latin');
478 is(@$r2, $n1, "modifying results should not mess up internal caches");
483 is(charinfo(0xdeadbeef), undef, "[perl #23273] warnings in Unicode::UCD");
486 use Unicode::UCD qw(namedseq);
488 is(namedseq("KATAKANA LETTER AINU P"), "\x{31F7}\x{309A}", "namedseq");
489 is(namedseq("KATAKANA LETTER AINU Q"), undef);
490 is(namedseq(), undef);
491 is(namedseq(qw(foo bar)), undef);
492 my @ns = namedseq("KATAKANA LETTER AINU P");
497 is($ns{"KATAKANA LETTER AINU P"}, "\x{31F7}\x{309A}");
501 use Unicode::UCD qw(num);
502 use charnames ":full";
504 is(num("0"), 0, 'Verify num("0") == 0');
505 is(num("98765"), 98765, 'Verify num("98765") == 98765');
506 ok(! defined num("98765\N{FULLWIDTH DIGIT FOUR}"), 'Verify num("98765\N{FULLWIDTH DIGIT FOUR}") isnt defined');
507 is(num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}"), 21, 'Verify num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}") == 21');
508 ok(! defined num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}"), 'Verify num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}") isnt defined');
509 is(num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}"), 3, 'Verify num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}") == 3');
510 ok(! defined num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}"), 'Verify num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}") isnt defined');
511 is(num("\N{SUPERSCRIPT TWO}"), 2, 'Verify num("\N{SUPERSCRIPT TWO} == 2');
512 is(num("\N{ETHIOPIC NUMBER TEN THOUSAND}"), 10000, 'Verify num("\N{ETHIOPIC NUMBER TEN THOUSAND}") == 10000');
513 is(num("\N{NORTH INDIC FRACTION ONE HALF}"), .5, 'Verify num("\N{NORTH INDIC FRACTION ONE HALF}") == .5');
514 is(num("\N{U+12448}"), 9, 'Verify num("\N{U+12448}") == 9');
515 is(num("\N{U+5146}"), 1000000000000, 'Verify num("\N{U+5146}") == 1000000000000');
517 # Create a user-defined property
523 use Unicode::UCD qw(prop_aliases);
525 is(prop_aliases(undef), undef, "prop_aliases(undef) returns <undef>");
526 is(prop_aliases("unknown property"), undef,
527 "prop_aliases(<unknown property>) returns <undef>");
528 is(prop_aliases("InKana"), undef,
529 "prop_aliases(<user-defined property>) returns <undef>");
530 is(prop_aliases("Perl_Decomposition_Mapping"), undef, "prop_aliases('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
531 is(prop_aliases("Perl_Charnames"), undef,
532 "prop_aliases('Perl_Charnames') returns <undef> since internal-Perl-only");
533 is(prop_aliases("isgc"), undef,
534 "prop_aliases('isgc') returns <undef> since is not covered Perl extension");
535 is(prop_aliases("Is_Is_Any"), undef,
536 "prop_aliases('Is_Is_Any') returns <undef> since two is's");
538 require 'utf8_heavy.pl';
539 require "unicore/Heavy.pl";
541 # Keys are lists of properties. Values are defined if have been tested.
544 # To test for loose matching, add in the characters that are ignored there.
545 my $extra_chars = "-_ ";
547 # The one internal property we accept
548 $props{'Perl_Decimal_Digit'} = 1;
549 my @list = prop_aliases("perldecimaldigit");
551 [ "Perl_Decimal_Digit",
553 ], "prop_aliases('perldecimaldigit') returns Perl_Decimal_Digit as both short and full names");
555 # Get the official Unicode property name synonyms and test them.
558 skip "PropertyAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
559 open my $props, "<", "../lib/unicore/PropertyAliases.txt"
560 or die "Can't open Unicode PropertyAliases.txt";
563 s/\s*#.*//; # Remove comments
564 next if /^\s* $/x; # Ignore empty and comment lines
567 local $/ = $input_record_separator;
568 my $count = 0; # 0th field in line is short name; 1th is long name
572 foreach my $alias (split /\s*;\s*/) { # Fields are separated by
574 # Add in the characters that are supposed to be ignored, to test loose
575 # matching, which the tested function does on all inputs.
576 my $mod_name = "$extra_chars$alias";
578 my $loose = &utf8::_loose_name(lc $alias);
580 # Indicate we have tested this.
583 my @all_names = prop_aliases($mod_name);
584 if (grep { $_ eq $loose } @Unicode::UCD::suppressed_properties) {
585 is(@all_names, 0, "prop_aliases('$mod_name') returns undef since $alias is not installed");
588 elsif (! @all_names) {
589 fail("prop_aliases('$mod_name')");
590 diag("'$alias' is unknown to prop_aliases()");
594 if ($count == 0) { # Is short name
596 @names_via_short = prop_aliases($mod_name);
598 # If the 0th test fails, no sense in continuing with the others
599 last unless is($names_via_short[0], $alias,
600 "prop_aliases: '$alias' is the short name for '$mod_name'");
601 $short_name = $alias;
603 elsif ($count == 1) { # Is full name
605 # Some properties have the same short and full name; no sense
606 # repeating the test if the same.
607 if ($alias ne $short_name) {
608 my @names_via_full = prop_aliases($mod_name);
609 is_deeply(\@names_via_full, \@names_via_short, "prop_aliases() returns the same list for both '$short_name' and '$mod_name'");
612 # Tests scalar context
613 is(prop_aliases($short_name), $alias,
614 "prop_aliases: '$alias' is the long name for '$short_name'");
616 else { # Is another alias
617 is_deeply(\@all_names, \@names_via_short, "prop_aliases() returns the same list for both '$short_name' and '$mod_name'");
618 ok((grep { $_ =~ /^$alias$/i } @all_names),
619 "prop_aliases: '$alias' is listed as an alias for '$mod_name'");
625 } # End of SKIP block
627 # Now test anything we can find that wasn't covered by the tests of the
628 # official properties. We have no way of knowing if mktables omitted a Perl
629 # extension or not, but we do the best we can from its generated lists
631 foreach my $alias (sort keys %utf8::loose_to_file_of) {
632 next if $alias =~ /=/;
633 my $lc_name = lc $alias;
634 my $loose = &utf8::_loose_name($lc_name);
635 next if exists $props{$loose}; # Skip if already tested
637 my $mod_name = "$extra_chars$alias"; # Tests loose matching
638 my @aliases = prop_aliases($mod_name);
639 my $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
641 pass("prop_aliases: '$lc_name' is listed as an alias for '$mod_name'");
643 elsif ($lc_name =~ /l[_&]$/) {
645 # These two names are special in that they don't appear in the
646 # returned list because they are discouraged from use. Verify
647 # that they return the same list as a non-discouraged version.
648 my @LC = prop_aliases('Is_LC');
649 is_deeply(\@aliases, \@LC, "prop_aliases: '$lc_name' returns the same list as 'Is_LC'");
652 my $stripped = $lc_name =~ s/^is//;
654 # Could be that the input includes a prefix 'is', which is rarely
655 # returned as an alias, so having successfully stripped it off above,
658 $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
661 # If that didn't work, it could be that it's a block, which is always
662 # returned with a leading 'In_' to avoid ambiguity. Try comparing
663 # with that stripped off.
665 $found_it = grep { &utf8::_loose_name(s/^In_(.*)/\L$1/r) eq $lc_name }
667 # Could check that is a real block, but tests for invmap will
668 # likely pickup any errors, since this will be tested there.
669 $lc_name = "in$lc_name" if $found_it; # Change for message below
671 my $message = "prop_aliases: '$lc_name' is listed as an alias for '$mod_name'";
672 ($found_it) ? pass($message) : fail($message);
677 foreach my $alias (keys %utf8::stricter_to_file_of) {
678 if ($alias =~ /=/) { # Only test one case where there is an equals
679 next if $done_equals;
682 my $lc_name = lc $alias;
683 my @list = prop_aliases($alias);
684 if ($alias =~ /^_/) {
685 is(@list, 0, "prop_aliases: '$lc_name' returns an empty list since it is internal_only");
687 elsif ($alias =~ /=/) {
688 is(@list, 0, "prop_aliases: '$lc_name' returns an empty list since is illegal property name");
691 ok((grep { lc $_ eq $lc_name } @list),
692 "prop_aliases: '$lc_name' is listed as an alias for '$alias'");
696 use Unicode::UCD qw(prop_value_aliases);
698 is(prop_value_aliases("unknown property", "unknown value"), undef,
699 "prop_value_aliases(<unknown property>, <unknown value>) returns <undef>");
700 is(prop_value_aliases(undef, undef), undef,
701 "prop_value_aliases(undef, undef) returns <undef>");
702 is((prop_value_aliases("na", "A")), "A", "test that prop_value_aliases returns its input for properties that don't have synonyms");
703 is(prop_value_aliases("isgc", "C"), undef, "prop_value_aliases('isgc', 'C') returns <undef> since is not covered Perl extension");
704 is(prop_value_aliases("gc", "isC"), undef, "prop_value_aliases('gc', 'isC') returns <undef> since is not covered Perl extension");
706 # We have no way of knowing if mktables omitted a Perl extension that it
707 # shouldn't have, but we can check if it omitted an official Unicode property
708 # name synonym. And for those, we can check if the short and full names are
711 my %pva_tested; # List of things already tested.
714 skip "PropValueAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
715 open my $propvalues, "<", "../lib/unicore/PropValueAliases.txt"
716 or die "Can't open Unicode PropValueAliases.txt";
718 while (<$propvalues>) {
719 s/\s*#.*//; # Remove comments
720 next if /^\s* $/x; # Ignore empty and comment lines
722 local $/ = $input_record_separator;
724 # Fix typo in official input file
725 s/CCC133/CCC132/g if $v_unicode_version eq v6.1.0;
727 my @fields = split /\s*;\s*/; # Fields are separated by semi-colons
728 my $prop = shift @fields; # 0th field is the property,
729 my $count = 0; # 0th field in line (after shifting off the property) is
730 # short name; 1th is long name
732 my @names_via_short; # Saves the values between iterations
734 # The property on the lhs of the = is always loosely matched. Add in
735 # characters that are ignored under loose matching to test that
736 my $mod_prop = "$extra_chars$prop";
738 if ($fields[0] eq 'n/a') { # See comments in input file, essentially
739 # means full name and short name are identical
740 $fields[0] = $fields[1];
742 elsif ($fields[0] ne $fields[1]
743 && &utf8::_loose_name(lc $fields[0])
744 eq &utf8::_loose_name(lc $fields[1])
745 && $fields[1] !~ /[[:upper:]]/)
747 # Also, there is a bug in the file in which "n/a" is omitted, and
748 # the two fields are identical except for case, and the full name
749 # is all lower case. Copy the "short" name unto the full one to
750 # give it some upper case.
752 $fields[1] = $fields[0];
755 # The ccc property in the file is special; has an extra numeric field
756 # (0th), which should go at the end, since we use the next two fields as
757 # the short and full names, respectively. See comments in input file.
758 splice (@fields, 0, 0, splice(@fields, 1, 2)) if $prop eq 'ccc';
760 my $loose_prop = &utf8::_loose_name(lc $prop);
761 my $suppressed = grep { $_ eq $loose_prop }
762 @Unicode::UCD::suppressed_properties;
763 foreach my $value (@fields) {
765 is(prop_value_aliases($prop, $value), undef, "prop_value_aliases('$prop', '$value') returns undef for suppressed property $prop");
768 elsif (grep { $_ eq ("$loose_prop=" . &utf8::_loose_name(lc $value)) } @Unicode::UCD::suppressed_properties) {
769 is(prop_value_aliases($prop, $value), undef, "prop_value_aliases('$prop', '$value') returns undef for suppressed property $prop=$value");
773 # Add in test for loose matching.
774 my $mod_value = "$extra_chars$value";
776 # If the value is a number, optionally negative, including a floating
777 # point or rational numer, it should be only strictly matched, so the
778 # loose matching should fail.
779 if ($value =~ / ^ -? \d+ (?: [\/.] \d+ )? $ /x) {
780 is(prop_value_aliases($mod_prop, $mod_value), undef, "prop_value_aliases('$mod_prop', '$mod_value') returns undef because '$mod_value' should be strictly matched");
782 # And reset so below tests just the strict matching.
788 @names_via_short = prop_value_aliases($mod_prop, $mod_value);
790 # If the 0th test fails, no sense in continuing with the others
791 last unless is($names_via_short[0], $value, "prop_value_aliases: In '$prop', '$value' is the short name for '$mod_value'");
792 $short_name = $value;
794 elsif ($count == 1) {
796 # Some properties have the same short and full name; no sense
797 # repeating the test if the same.
798 if ($value ne $short_name) {
800 prop_value_aliases($mod_prop, $mod_value);
801 is_deeply(\@names_via_full, \@names_via_short, "In '$prop', prop_value_aliases() returns the same list for both '$short_name' and '$mod_value'");
804 # Tests scalar context
805 is(prop_value_aliases($prop, $short_name), $value, "'$value' is the long name for prop_value_aliases('$prop', '$short_name')");
808 my @all_names = prop_value_aliases($mod_prop, $mod_value);
809 is_deeply(\@all_names, \@names_via_short, "In '$prop', prop_value_aliases() returns the same list for both '$short_name' and '$mod_value'");
810 ok((grep { &utf8::_loose_name(lc $_) eq &utf8::_loose_name(lc $value) } prop_value_aliases($prop, $short_name)), "'$value' is listed as an alias for prop_value_aliases('$prop', '$short_name')");
813 $pva_tested{&utf8::_loose_name(lc $prop) . "=" . &utf8::_loose_name(lc $value)} = 1;
817 } # End of SKIP block
819 # And test as best we can, the non-official pva's that mktables generates.
820 foreach my $hash (\%utf8::loose_to_file_of, \%utf8::stricter_to_file_of) {
821 foreach my $test (sort keys %$hash) {
822 next if exists $pva_tested{$test}; # Skip if already tested
824 my ($prop, $value) = split "=", $test;
825 next unless defined $value; # prop_value_aliases() requires an input
828 if ($hash == \%utf8::loose_to_file_of) {
830 # Add extra characters to test loose-match rhs value
831 $mod_value = "$extra_chars$value";
833 else { # Here value is strictly matched.
835 # Extra elements are added by mktables to this hash so that
836 # something like "age=6.0" has a synonym of "age=6". It's not
837 # clear to me (khw) if we should be encouraging those synonyms, so
838 # don't test for them.
839 next if $value !~ /\D/ && exists $hash->{"$prop=$value.0"};
841 # Verify that loose matching fails when only strict is called for.
842 next unless is(prop_value_aliases($prop, "$extra_chars$value"), undef,
843 "prop_value_aliases('$prop', '$extra_chars$value') returns undef since '$value' should be strictly matched"),
845 # Strict matching does allow for underscores between digits. Test
848 while ($mod_value =~ s/(\d)(\d)/$1_$2/g) {}
851 # The lhs property is always loosely matched, so add in extra
852 # characters to test that.
853 my $mod_prop = "$extra_chars$prop";
855 if ($prop eq 'gc' && $value =~ /l[_&]$/) {
856 # These two names are special in that they don't appear in the
857 # returned list because they are discouraged from use. Verify
858 # that they return the same list as a non-discouraged version.
859 my @LC = prop_value_aliases('gc', 'lc');
860 my @l_ = prop_value_aliases($mod_prop, $mod_value);
861 is_deeply(\@l_, \@LC, "prop_value_aliases('$mod_prop', '$mod_value) returns the same list as prop_value_aliases('gc', 'lc')");
864 ok((grep { &utf8::_loose_name(lc $_) eq &utf8::_loose_name(lc $value) }
865 prop_value_aliases($mod_prop, $mod_value)),
866 "'$value' is listed as an alias for prop_value_aliases('$mod_prop', '$mod_value')");
873 no warnings 'once'; # We use some values once from 'required' modules.
875 use Unicode::UCD qw(prop_invlist prop_invmap MAX_CP);
877 # There were some problems with caching interfering with prop_invlist() vs
878 # prop_invmap() on binary properties, and also between the 3 properties where
879 # Perl used the same 'To' name as another property (see utf8_heavy.pl).
880 # So, before testing all of prop_invlist(),
881 # 1) call prop_invmap() to try both orders of these name issues. This uses
882 # up two of the 3 properties; the third will be left so that invlist()
883 # on it gets called before invmap()
884 # 2) call prop_invmap() on a generic binary property, ahead of invlist().
885 # This should test that the caching works in both directions.
887 # These properties are not stable between Unicode versions, but the first few
888 # elements are; just look at the first element to see if are getting the
889 # distinction right. The general inversion map testing below will test the
892 my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
893 is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
894 is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
895 is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
896 is($invmap_ref->[1], 0x41, "prop_invmap('$prop') map[1] is 0x41");
899 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
900 is($format, 's', "prop_invmap() format of '$prop' is 's");
901 is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
902 is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
903 is($invmap_ref->[1], 'Y', "prop_invmap('$prop') map[1] is 'Y'");
906 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
907 is($format, 's', "prop_invmap() format of '$prop' is 's'");
908 is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
909 is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
910 is($invmap_ref->[1], 'Y', "prop_invmap('$prop') map[1] is 'Y'");
913 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
914 is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
915 is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
916 is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
917 is($invmap_ref->[1], 0x61, "prop_invmap('$prop') map[1] is 0x61");
919 # This property is stable and small, so can test all of it
920 $prop = "ASCII_Hex_Digit";
921 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
922 is($format, 's', "prop_invmap() format of '$prop' is 's'");
923 is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
924 is_deeply($invlist_ref, [ 0x0000, 0x0030, 0x003A, 0x0041,
925 0x0047, 0x0061, 0x0067, 0x110000 ],
926 "prop_invmap('$prop') code point list is correct");
927 is_deeply($invmap_ref, [ 'N', 'Y', 'N', 'Y', 'N', 'Y', 'N', 'N' ] ,
928 "prop_invmap('$prop') map list is correct");
930 is(prop_invlist("Unknown property"), undef, "prop_invlist(<Unknown property>) returns undef");
931 is(prop_invlist(undef), undef, "prop_invlist(undef) returns undef");
932 is(prop_invlist("Any"), 2, "prop_invlist('Any') returns the number of elements in scalar context");
933 my @invlist = prop_invlist("Is_Any");
934 is_deeply(\@invlist, [ 0, 0x110000 ], "prop_invlist works on 'Is_' prefixes");
935 is(prop_invlist("Is_Is_Any"), undef, "prop_invlist('Is_Is_Any') returns <undef> since two is's");
937 use Storable qw(dclone);
939 is(prop_invlist("InKana"), undef, "prop_invlist(<user-defined property returns undef>)");
941 # The way both the tests for invlist and invmap work is that they take the
942 # lists returned by the functions and construct from them what the original
943 # file should look like, which are then compared with the file. If they are
944 # identical, the test passes. What this tests isn't that the results are
945 # correct, but that invlist and invmap haven't introduced errors beyond what
946 # are there in the files. As a small hedge against that, test some
947 # prop_invlist() tables fully with the known correct result. We choose
948 # ASCII_Hex_Digit again, as it is stable.
949 @invlist = prop_invlist("AHex");
950 is_deeply(\@invlist, [ 0x0030, 0x003A, 0x0041,
951 0x0047, 0x0061, 0x0067 ],
952 "prop_invlist('AHex') is exactly the expected set of points");
953 @invlist = prop_invlist("AHex=f");
954 is_deeply(\@invlist, [ 0x0000, 0x0030, 0x003A, 0x0041,
955 0x0047, 0x0061, 0x0067 ],
956 "prop_invlist('AHex=f') is exactly the expected set of points");
958 sub fail_with_diff ($$$$) {
959 # For use below to output better messages
960 my ($prop, $official, $constructed, $tested_function_name) = @_;
962 is($constructed, $official, "$tested_function_name('$prop')");
963 diag("Comment out lines " . (__LINE__ - 1) . " through " . (__LINE__ + 1) . " in '$0' on Un*x-like systems to see just the differences. Uses the 'diff' first in your \$PATH");
966 fail("$tested_function_name('$prop')");
969 my $off = File::Temp->new();
972 print $off $official, "\n";
973 close $off || die "Can't close official";
976 my $gend = File::Temp->new();
977 print $gend $constructed, "\n";
978 close $gend || die "Can't close gend";
980 my $diff = File::Temp->new();
981 system("diff $off $gend > $diff");
983 open my $fh, "<", $diff || die "Can't open $diff";
985 diag("In the diff output below '<' marks lines from the filesystem tables;\n'>' are from $tested_function_name()");
991 # Look at everything we think that mktables tells us exists, both loose and
993 foreach my $set_of_tables (\%utf8::stricter_to_file_of, \%utf8::loose_to_file_of)
995 foreach my $table (sort keys %$set_of_tables) {
998 my ($prop_only, $value) = split "=", $table;
999 if (defined $value) {
1001 # If this is to be loose matched, add in characters to test that.
1002 if ($set_of_tables == \%utf8::loose_to_file_of) {
1003 $value = "$extra_chars$value";
1005 else { # Strict match
1007 # Verify that loose matching fails when only strict is called
1009 next unless is(prop_invlist("$prop_only=$extra_chars$value"), undef, "prop_invlist('$prop_only=$extra_chars$value') returns undef since should be strictly matched");
1011 # Strict matching does allow for underscores between digits.
1013 while ($value =~ s/(\d)(\d)/$1_$2/g) {}
1016 # The property portion in compound form specifications always
1018 $mod_table = "$extra_chars$prop_only = $value";
1020 else { # Single-form.
1022 # Like above, use loose if required, and insert underscores
1023 # between digits if strict.
1024 if ($set_of_tables == \%utf8::loose_to_file_of) {
1025 $mod_table = "$extra_chars$table";
1028 $mod_table = $table;
1029 while ($mod_table =~ s/(\d)(\d)/$1_$2/g) {}
1033 my @tested = prop_invlist($mod_table);
1034 if ($table =~ /^_/) {
1035 is(@tested, 0, "prop_invlist('$mod_table') returns an empty list since is internal-only");
1039 # If we have already tested a property that uses the same file, this
1040 # list should be identical to the one that was tested, and can bypass
1042 my $file = $set_of_tables->{$table};
1043 if (exists $tested_invlist{$file}) {
1044 is_deeply(\@tested, $tested_invlist{$file}, "prop_invlist('$mod_table') gave same results as its name synonym");
1047 $tested_invlist{$file} = dclone \@tested;
1049 # A leading '!' in the file name means that it is to be inverted.
1050 my $invert = $file =~ s/^!//;
1051 my $official = do "unicore/lib/$file.pl";
1053 # Get rid of any trailing space and comments in the file.
1054 $official =~ s/\s*(#.*)?$//mg;
1057 $/ = $input_record_separator;
1059 # If we are to test against an inverted file, it is easier to invert
1060 # our array than the file.
1061 # The file only is valid for Unicode code points, while the inversion
1062 # list is valid for all possible code points. Therefore, we must test
1063 # just the Unicode part against the file. Later we will test for
1064 # the non-Unicode part.
1066 my $before_invert; # Saves the pre-inverted table.
1068 $before_invert = dclone \@tested;
1069 if (@tested && $tested[0] == 0) {
1074 if (@tested && $tested[-1] == 0x110000) {
1078 push @tested, 0x110000;
1082 # Now construct a string from the list that should match the file.
1083 # The file gives ranges of code points with starting and ending values
1084 # in hex, like this:
1088 # Our list has even numbered elements start ranges that are in the
1089 # list, and odd ones that aren't in the list. Therefore the odd
1090 # numbered ones are one beyond the end of the previous range, but
1091 # otherwise don't get reflected in the file.
1094 for (; $i < @tested - 1; $i += 2) {
1095 my $start = $tested[$i];
1096 my $end = $tested[$i+1] - 1;
1097 if ($start == $end) {
1098 $tested .= sprintf("%X\n", $start);
1101 $tested .= sprintf "%X\t%X\n", $start, $end;
1105 # As mentioned earlier, the disk files only go up through Unicode,
1106 # whereas the prop_invlist() ones go as high as necessary. The
1107 # comparison is only valid through max Unicode.
1108 if ($i == @tested - 1 && $tested[$i] <= 0x10FFFF) {
1109 $tested .= sprintf("%X\t10FFFF\n", $tested[$i]);
1113 $/ = $input_record_separator;
1114 if ($tested ne $official) {
1115 fail_with_diff($mod_table, $official, $tested, "prop_invlist");
1119 # Here, it matched the table. Now need to check for if it is correct
1120 # for beyond Unicode. First, calculate if is the default table or
1121 # not. This is the same algorithm as used internally in
1122 # prop_invlist(), so if it is wrong there, this test won't catch it.
1123 my $prop = lc $table;
1124 ($prop_only, $table) = split /\s*[:=]\s*/, $prop;
1125 if (defined $table) {
1127 # May have optional prefixed 'is'
1128 $prop = &utf8::_loose_name($prop_only) =~ s/^is//r;
1129 $prop = $utf8::loose_property_name_of{$prop};
1130 $prop .= "=" . &utf8::_loose_name($table);
1133 $prop = &utf8::_loose_name($prop);
1135 my $is_default = exists $Unicode::UCD::loose_defaults{$prop};
1137 @tested = @$before_invert if $invert; # Use the original
1138 if (@tested % 2 == 0) {
1140 # If there are an even number of elements, the final one starts a
1141 # range (going to infinity) of code points that are not in the
1144 fail("prop_invlist('$mod_table')");
1145 diag("default table doesn't goto infinity");
1147 diag Dumper \@tested;
1152 # An odd number of elements means the final one starts a range
1153 # (going to infinity of code points that are in the list.
1154 if (! $is_default) {
1155 fail("prop_invlist('$mod_table')");
1156 diag("non-default table needs to stop in the Unicode range");
1158 diag Dumper \@tested;
1163 pass("prop_invlist('$mod_table')");
1167 # Now test prop_invmap().
1169 @list = prop_invmap("Unknown property");
1170 is (@list, 0, "prop_invmap(<Unknown property>) returns an empty list");
1171 @list = prop_invmap(undef);
1172 is (@list, 0, "prop_invmap(undef) returns an empty list");
1173 ok (! eval "prop_invmap('gc')" && $@ ne "",
1174 "prop_invmap('gc') dies in scalar context");
1175 @list = prop_invmap("_X_Begin");
1176 is (@list, 0, "prop_invmap(<internal property>) returns an empty list");
1177 @list = prop_invmap("InKana");
1178 is(@list, 0, "prop_invmap(<user-defined property returns undef>)");
1179 @list = prop_invmap("Perl_Decomposition_Mapping"), undef,
1180 is(@list, 0, "prop_invmap('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
1181 @list = prop_invmap("Perl_Charnames"), undef,
1182 is(@list, 0, "prop_invmap('Perl_Charnames') returns <undef> since internal-Perl-only");
1183 @list = prop_invmap("Is_Is_Any");
1184 is(@list, 0, "prop_invmap('Is_Is_Any') returns <undef> since two is's");
1186 # The files for these properties are not used by Perl, but are retained for
1187 # backwards compatibility with applications that read them directly, with
1188 # comments in them that their use is deprecated. Until such time as we remove
1189 # them completely, we test that they exist, are correct, and that their
1190 # formats haven't changed. This hash contains the info needed to test them as
1191 # if they were regular properties. 'replaced_by' gives the equivalent
1192 # property now used by Perl.
1193 my %legacy_props = (
1194 Legacy_Case_Folding => { replaced_by => 'cf',
1196 swash_name => 'ToFold'
1198 Legacy_Lowercase_Mapping => { replaced_by => 'lc',
1200 swash_name => 'ToLower'
1202 Legacy_Titlecase_Mapping => { replaced_by => 'tc',
1204 swash_name => 'ToTitle'
1206 Legacy_Uppercase_Mapping => { replaced_by => 'uc',
1208 swash_name => 'ToUpper'
1210 Legacy_Perl_Decimal_Digit => { replaced_by => 'Perl_Decimal_Digit',
1212 swash_name => 'ToDigit'
1216 foreach my $legacy_prop (keys %legacy_props) {
1217 @list = prop_invmap($legacy_prop);
1218 is(@list, 0, "'$legacy_prop' is unknown to prop_invmap");
1221 # The files for these properties shouldn't have their formats changed in case
1222 # applications use them (though such use is deprecated).
1223 my @legacy_file_format = (keys %legacy_props,
1224 qw( Bidi_Mirroring_Glyph
1229 # The set of properties to test on has already been compiled into %props by
1230 # the prop_aliases() tests.
1234 # Like prop_invlist(), prop_invmap() is tested by comparing the results
1235 # returned by the function with the tables that mktables generates. Some of
1236 # these tables are directly stored as files on disk, in either the unicore or
1237 # unicore/To directories, and most should be listed in the mktables generated
1238 # hash %utf8::loose_property_to_file_of, with a few additional ones that this
1239 # handles specially. For these, the files are read in directly, massaged, and
1240 # compared with what invmap() returns. The SPECIALS hash in some of these
1241 # files overrides values in the main part of the file.
1243 # The other properties are tested indirectly by generating all the possible
1244 # inversion lists for the property, and seeing if those match the inversion
1245 # lists returned by prop_invlist(), which has already been tested.
1248 foreach my $prop (sort(keys %props), sort keys %legacy_props) {
1250 my $loose_prop = &utf8::_loose_name(lc $prop);
1251 my $suppressed = grep { $_ eq $loose_prop }
1252 @Unicode::UCD::suppressed_properties;
1254 my $actual_lookup_prop;
1255 my $display_prop; # The property name that is displayed, as opposed
1256 # to the one that is actually used.
1258 # Find the short and full names that this property goes by
1259 my ($name, $full_name) = prop_aliases($prop);
1262 # Here, Perl doesn't know about this property. It could be a
1263 # suppressed one, or a legacy one.
1264 if (grep { $prop eq $_ } keys %legacy_props) {
1266 # For legacy properties, we look up the modern equivalent
1267 # property instead; later massaging the results to look like the
1268 # known format of the legacy property. We add info about the
1269 # legacy property to the data structures for the rest of the
1270 # properties; this is to avoid more special cases for the legacies
1272 $full_name = $name = $prop;
1273 $actual_lookup_prop = $legacy_props{$prop}->{'replaced_by'};
1274 my $base_file = $legacy_props{$prop}->{'file'};
1276 # This legacy property is otherwise unknown to Perl; so shouldn't
1277 # have any information about it already.
1278 ok(! exists $utf8::loose_property_to_file_of{$loose_prop},
1279 "There isn't a hash entry for file lookup of $prop");
1280 $utf8::loose_property_to_file_of{$loose_prop} = $base_file;
1282 ok(! exists $utf8::file_to_swash_name{$loose_prop},
1283 "There isn't a hash entry for swash lookup of $prop");
1284 $utf8::file_to_swash_name{$base_file}
1285 = $legacy_props{$prop}->{'swash_name'};
1286 $display_prop = $prop;
1290 if (! $suppressed) {
1291 fail("prop_invmap('$prop')");
1292 diag("is unknown to prop_aliases(), and we need it in order to test prop_invmap");
1298 # Normalize the short name, as it is stored in the hashes under the
1299 # normalized version.
1300 $name = &utf8::_loose_name(lc $name);
1302 # Add in the characters that are supposed to be ignored to test loose
1303 # matching, which the tested function applies to all properties
1304 $display_prop = "$extra_chars$prop" unless $display_prop;
1305 $actual_lookup_prop = $display_prop unless $actual_lookup_prop;
1307 my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($actual_lookup_prop);
1308 my $return_ref = [ $invlist_ref, $invmap_ref, $format, $missing ];
1311 # The legacy property files all are expanded out so that each range is 1
1312 # element long. That isn't true of the modern equivalent we use to check
1313 # those files for correctness against. So take the output of the proxy
1314 # and expand it to match the legacy file.
1318 for my $i (0 .. @$invlist_ref - 1 - 1) {
1319 if (ref $invmap_ref->[$i] || $invmap_ref->[$i] eq $missing) {
1321 # No adjustments should be done for the default mapping and
1322 # the multi-char ones.
1323 push @expanded_list, $invlist_ref->[$i];
1324 push @expanded_map, $invmap_ref->[$i];
1328 # Expand the range into separate elements for each item.
1330 for my $j ($invlist_ref->[$i] .. $invlist_ref->[$i+1] -1) {
1331 push @expanded_list, $j;
1332 push @expanded_map, $invmap_ref->[$i] + $offset;
1334 # The 'ae' format is for Legacy_Perl_Decimal_Digit; the
1335 # other 4 are kept with leading zeros in the file, so
1337 $expanded_map[-1] = sprintf("%04X", $expanded_map[-1])
1344 # Final element is taken as is. The map should always be to the
1345 # default value, so don't do a sprintf like we did above.
1346 push @expanded_list, $invlist_ref->[-1];
1347 push @expanded_map, $invmap_ref->[-1];
1349 $invlist_ref = \@expanded_list;
1350 $invmap_ref = \@expanded_map;
1353 # If have already tested this property under a different name, merely
1354 # compare the return from now with the saved one from before.
1355 if (exists $tested_invmaps{$name}) {
1356 is_deeply($return_ref, $tested_invmaps{$name}, "prop_invmap('$display_prop') gave same results as its synonym, '$name'");
1359 $tested_invmaps{$name} = dclone $return_ref;
1361 # If prop_invmap() returned nothing, is ok iff is a property whose file is
1364 if (defined $format) {
1365 fail("prop_invmap('$display_prop')");
1366 diag("did not return undef for suppressed property $prop");
1370 elsif (!defined $format) {
1371 fail("prop_invmap('$display_prop')");
1372 diag("'$prop' is unknown to prop_invmap()");
1376 # The two parallel arrays must have the same number of elements.
1377 if (@$invlist_ref != @$invmap_ref) {
1378 fail("prop_invmap('$display_prop')");
1380 . scalar @$invlist_ref
1381 . " while invmap has "
1382 . scalar @$invmap_ref
1387 # The last element must be for the above-Unicode code points, and must be
1388 # for the default value.
1389 if ($invlist_ref->[-1] != 0x110000) {
1390 fail("prop_invmap('$display_prop')");
1391 diag("The last inversion list element is not 0x110000");
1394 if ($invmap_ref->[-1] ne $missing) {
1395 fail("prop_invmap('$display_prop')");
1396 diag("The last inversion list element is '$invmap_ref->[-1]', and should be '$missing'");
1400 if ($name eq 'bmg') { # This one has an atypical $missing
1401 if ($missing ne "") {
1402 fail("prop_invmap('$display_prop')");
1403 diag("The missings should be \"\"; got '$missing'");
1407 elsif ($format =~ /^ a (?!r) /x) {
1408 if ($full_name eq 'Perl_Decimal_Digit') {
1409 if ($missing ne "") {
1410 fail("prop_invmap('$display_prop')");
1411 diag("The missings should be \"\"; got '$missing'");
1415 elsif ($missing ne "0" && ! grep { $prop eq $_ } keys %legacy_props) {
1416 fail("prop_invmap('$display_prop')");
1417 diag("The missings should be '0'; got '$missing'");
1421 elsif ($missing =~ /[<>]/) {
1422 fail("prop_invmap('$display_prop')");
1423 diag("The missings should NOT be something with <...>'");
1426 # I don't want to hard code in what all the missings should be, so
1427 # those don't get fully tested.
1430 # Certain properties don't have their own files, but must be constructed
1432 my $proxy_prop = $name;
1433 if ($full_name eq 'Present_In') {
1434 $proxy_prop = "age"; # The maps for these two props are identical
1436 elsif ($full_name eq 'Simple_Case_Folding'
1437 || $full_name =~ /Simple_ (.) .*? case_Mapping /x)
1439 if ($full_name eq 'Simple_Case_Folding') {
1443 # We captured the U, L, or T, leading to uc, lc, or tc.
1444 $proxy_prop = lc $1 . "c";
1446 if ($format ne "a") {
1447 fail("prop_invmap('$display_prop')");
1448 diag("The format should be 'a'; got '$format'");
1453 if ($format !~ / ^ (?: a [der]? | ale? | n | sl? ) $ /x) {
1454 fail("prop_invmap('$display_prop')");
1455 diag("Unknown format '$format'");
1462 # Handle the properties that have full disk files for them (except the
1463 # Name property which is structurally enough different that it is handled
1464 # separately below.)
1468 ($base_file = $utf8::loose_property_to_file_of{$proxy_prop})
1469 || exists $utf8::loose_to_file_of{$proxy_prop}
1472 # In the above, blk is done unconditionally, as we need to test that
1473 # the old-style block names are returned, even if mktables has
1474 # generated a file for the new-style; the test for dm comes afterward,
1475 # so that if a file has been generated for it explicitly, we use that
1476 # file (which is valid, unlike blk) instead of the combo
1477 # Decomposition.pl files.
1480 if ($name eq 'blk') {
1482 # The blk property is special. The original file with old block
1483 # names is retained, and the default is to not write out a
1484 # new-name file. What we do is get the old names into a data
1485 # structure, and from that create what the new file would look
1486 # like. $base_file is needed to be defined, just to avoid a
1488 $base_file = "This is a dummy name";
1489 my $blocks_ref = charblocks();
1491 for my $range (sort { $a->[0][0] <=> $b->[0][0] }
1492 values %$blocks_ref)
1494 # Translate the charblocks() data structure to what the file
1496 $official .= sprintf"%X\t%X\t%s\n",
1503 $base_file = "Decomposition" if $format eq 'ad';
1505 # Above leaves $base_file undefined only if it came from the hash
1506 # below. This should happen only when it is a binary property
1507 # (and are accessing via a single-form name, like 'In_Latin1'),
1508 # and so it is stored in a different directory than the To ones.
1509 # XXX Currently, the only cases where it is complemented are the
1510 # ones that have no code points. And it works out for these that
1511 # 1) complementing them, and then 2) adding or subtracting the
1512 # initial 0 and final 110000 cancel each other out. But further
1513 # work would be needed in the unlikely event that an inverted
1514 # property comes along without these characteristics
1515 if (!defined $base_file) {
1516 $base_file = $utf8::loose_to_file_of{$proxy_prop};
1517 $is_binary = ($base_file =~ s/^!//) ? -1 : 1;
1518 $base_file = "lib/$base_file";
1522 $file = "unicore/$base_file.pl";
1523 $official = do $file;
1525 # Get rid of any trailing space and comments in the file.
1526 $official =~ s/\s*(#.*)?$//mg;
1528 if ($format eq 'ad') {
1529 my @official = split /\n/, $official;
1531 foreach my $line (@official) {
1532 my ($start, $end, $value)
1533 = $line =~ / ^ (.+?) \t (.*?) \t (.+?)
1534 \s* ( \# .* )? $ /x;
1535 # Decomposition.pl also has the <compatible> types in it,
1536 # which should be removed.
1537 $value =~ s/<.*?> //;
1538 $official .= "$start\t\t$value\n";
1540 # If this is a multi-char range, we turn it into as many
1541 # single character ranges as necessary. This makes things
1544 for my $i (hex($start) + 1 .. hex $end) {
1545 $official .= sprintf "%X\t\t%s\n", $i, $value;
1553 $/ = $input_record_separator;
1555 # Get the format for the file, and if there are any special elements,
1556 # get a reference to them.
1557 my $swash_name = $utf8::file_to_swash_name{$base_file};
1559 my $file_format; # The 'format' given inside the file
1561 $specials_ref = $utf8::SwashInfo{$swash_name}{'specials_name'};
1562 if ($specials_ref) {
1564 # Convert from the name to the actual reference.
1566 $specials_ref = \%{$specials_ref};
1569 $file_format = $utf8::SwashInfo{$swash_name}{'format'};
1572 # Leading zeros used to be used with the values in the files that give,
1573 # ranges, but these have been mostly stripped off, except for some
1574 # files whose formats should not change in any way.
1575 my $file_range_format = (grep { $full_name eq $_ } @legacy_file_format)
1578 # Currently this property still has leading zeroes in the mapped-to
1579 # values, but otherwise, those values follow the same rules as the
1581 my $file_map_format = ($full_name eq 'Decomposition_Mapping')
1583 : $file_range_format;
1585 # Certain of the proxy properties have to be adjusted to match the
1588 =~ /^(Legacy_)?(Case_Folding|(Lower|Title|Upper)case_Mapping)/)
1591 # Here we have either
1592 # 1) Case_Folding; or
1593 # 2) a proxy that is a full mapping, which means that what the
1594 # real property is is the equivalent simple mapping.
1595 # In both cases, the file will have a standard list containing
1596 # simple mappings (to a single code point), and a specials hash
1597 # which contains all the mappings that are to multiple code
1598 # points. First, extract a list containing all the file's simple
1601 for (split "\n", $official) {
1602 my ($start, $end, $value) = / ^ (.+?) \t (.*?) \t (.+?)
1603 \s* ( \# .* )? $ /x;
1604 $end = $start if $end eq "";
1605 push @list, [ hex $start, hex $end, hex $value ];
1608 # For these mappings, the file contains all the simple mappings,
1609 # including the ones that are overridden by the specials. These
1610 # need to be removed as the list is for just the full ones.
1612 # Go through any special mappings one by one. They are packed.
1614 foreach my $utf8_cp (sort keys %$specials_ref) {
1615 my $cp = unpack("C0U", $utf8_cp);
1617 # Find the spot in the @list of simple mappings that this
1618 # special applies to; uses a linear search.
1619 while ($i < @list -1 ) {
1620 last if $cp <= $list[$i][1];
1624 # Here $i is such that it points to the first range which ends
1625 # at or above cp, and hence is the only range that could
1626 # possibly contain it.
1628 # If not in this range, no range contains it: nothing to
1630 next if $cp < $list[$i][0];
1632 # Otherwise, remove the existing entry. If it is the first
1633 # element of the range...
1634 if ($cp == $list[$i][0]) {
1636 # ... and there are other elements in the range, just
1637 # shorten the range to exclude this code point.
1638 if ($list[$i][1] > $list[$i][0]) {
1642 # ... but if it is the only element in the range, remove
1645 splice @list, $i, 1;
1648 else { # Is somewhere in the middle of the range
1649 # Split the range into two, excluding this one in the
1651 splice @list, $i, 1,
1652 [ $list[$i][0], $cp - 1, $list[$i][2] ],
1653 [ $cp + 1, $list[$i][1], $list[$i][2] ];
1657 # Here, have gone through all the specials, modifying @list as
1658 # needed. Turn it back into what the file should look like.
1660 for my $element (@list) {
1661 $official .= "\n" if $official;
1662 if ($element->[1] == $element->[0]) {
1664 .= sprintf "$file_range_format\t\t$file_map_format",
1665 $element->[0], $element->[2];
1668 $official .= sprintf "$file_range_format\t$file_range_format\t$file_map_format",
1676 =~ / ^ Simple_(Case_Folding|(Lower|Title|Upper)case_Mapping) $ /x)
1679 # These properties have everything in the regular array, and the
1680 # specials are superfluous.
1681 undef $specials_ref;
1683 elsif ($format !~ /^a/ && defined $file_format && $file_format eq 'x') {
1685 # For these properties the file is output using hex notation for the
1686 # map. Convert from hex to decimal.
1687 my @lines = split "\n", $official;
1688 foreach my $line (@lines) {
1689 my ($lower, $upper, $map) = split "\t", $line;
1690 $line = "$lower\t$upper\t" . hex $map;
1692 $official = join "\n", @lines;
1695 # Here, in $official, we have what the file looks like, or should like
1696 # if we've had to fix it up. Now take the invmap() output and reverse
1697 # engineer from that what the file should look like. Each iteration
1698 # appends the next line to the running string.
1699 my $tested_map = "";
1701 # Create a copy of the file's specials hash. (It has been undef'd if
1702 # we know it isn't relevant to this property, so if it exists, it's an
1703 # error or is relevant). As we go along, we delete from that copy.
1704 # If a delete fails, or something is left over after we are done,
1706 my %specials = %$specials_ref if $specials_ref;
1708 # The extra -1 is because the final element has been tested above to
1709 # be for anything above Unicode. The file doesn't go that high.
1710 for (my $i = 0; $i < @$invlist_ref - 1; $i++) {
1712 # If the map element is a reference, have to stringify it (but
1713 # don't do so if the format doesn't allow references, so that an
1714 # improper format will generate an error.
1715 if (ref $invmap_ref->[$i]
1716 && ($format eq 'ad' || $format =~ /^ . l /x))
1718 # The stringification depends on the format.
1719 if ($format eq 'sl') {
1721 # At the time of this writing, there are two types of 'sl'
1722 # format One, in Name_Alias, has multiple separate
1723 # entries for each code point; the other, in
1724 # Script_Extension, is space separated. Assume the latter
1725 # for non-Name_Alias.
1726 if ($full_name ne 'Name_Alias') {
1727 $invmap_ref->[$i] = join " ", @{$invmap_ref->[$i]};
1730 # For Name_Alias, we emulate the file. Entries with
1731 # just one value don't need any changes, but we
1732 # convert the list entries into a series of lines for
1733 # the file, starting with the first name. The
1734 # succeeding entries are on separate lines, with the
1735 # code point repeated for each one and then two tabs,
1736 # then the value. Code at the end of the loop will
1737 # set up the first line with its code point and two
1738 # tabs before the value, just as it does for every
1739 # other property; thus the special handling of the
1741 if (ref $invmap_ref->[$i]) {
1742 my $hex_cp = sprintf("%X", $invlist_ref->[$i]);
1743 my $concatenated = $invmap_ref->[$i][0];
1744 for (my $j = 1; $j < @{$invmap_ref->[$i]}; $j++) {
1745 $concatenated .= "\n$hex_cp\t\t"
1746 . $invmap_ref->[$i][$j];
1748 $invmap_ref->[$i] = $concatenated;
1752 elsif ($format =~ / ^ al e? $/x) {
1754 # For an al property, the stringified result should be in
1755 # the specials hash. The key is the packed code point,
1756 # and the value is the packed map.
1758 if (! defined ($value = delete $specials{pack("C0U",
1759 $invlist_ref->[$i]) }))
1761 fail("prop_invmap('$display_prop')");
1762 diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]);
1765 my $packed = pack "U*", @{$invmap_ref->[$i]};
1766 if ($value ne $packed) {
1767 fail("prop_invmap('$display_prop')");
1768 diag(sprintf "For %04X, expected the mapping to be '$packed', but got '$value'");
1772 # As this doesn't get tested when we later compare with
1773 # the actual file, it could be out of order and we
1775 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1776 || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1778 fail("prop_invmap('$display_prop')");
1779 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1784 elsif ($format eq 'ad') {
1786 # The decomposition mapping file has the code points as
1787 # a string of space-separated hex constants.
1788 $invmap_ref->[$i] = join " ", map { sprintf "%04X", $_ }
1789 @{$invmap_ref->[$i]};
1792 fail("prop_invmap('$display_prop')");
1793 diag("Can't handle format '$format'");
1796 } # Otherwise, the map is to a simple scalar
1797 elsif ($full_name =~ # These maps are in hex
1798 / ^ ( Simple_ )? ( Case_Folding
1801 | Upper ) case_Mapping ) $ /x)
1803 $invmap_ref->[$i] = sprintf("%X", $invmap_ref->[$i]);
1805 elsif ($format eq 'ad' || $format eq 'ale') {
1807 # The numerics in the returned map are stored as adjusted
1808 # decimal integers. The defaults are 0, and don't appear in
1809 # $official, and are excluded later, but the elements must be
1810 # converted back to their hex values before comparing with
1811 # $official, as these files, for backwards compatibility, are
1812 # not stored as adjusted. (There currently is only one ale
1813 # property, nfkccf. If that changed this would also have to.)
1814 if ($invmap_ref->[$i] =~ / ^ -? \d+ $ /x
1815 && $invmap_ref->[$i] != 0)
1817 my $next = $invmap_ref->[$i] + 1;
1818 $invmap_ref->[$i] = sprintf($file_map_format,
1821 # If there are other elements in this range they need to
1822 # be adjusted; they must individually be re-mapped. Do
1823 # this by splicing in a new element into the list and the
1824 # map containing the remainder of the range. Next time
1825 # through we will look at that (possibly splicing again
1826 # until the whole range is processed).
1827 if ($invlist_ref->[$i+1] > $invlist_ref->[$i] + 1) {
1828 splice @$invlist_ref, $i+1, 0,
1829 $invlist_ref->[$i] + 1;
1830 splice @$invmap_ref, $i+1, 0, $next;
1833 if ($format eq 'ale' && $invmap_ref->[$i] eq "") {
1835 # ale properties have maps to the empty string that also
1836 # should be in the specials hash, with the key the packed
1837 # code point, and the map just empty.
1839 if (! defined ($value = delete $specials{pack("C0U",
1840 $invlist_ref->[$i]) }))
1842 fail("prop_invmap('$display_prop')");
1843 diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]);
1847 fail("prop_invmap('$display_prop')");
1848 diag(sprintf "For %04X, expected the mapping to be \"\", but got '$value'", $invlist_ref->[$i]);
1852 # As this doesn't get tested when we later compare with
1853 # the actual file, it could be out of order and we
1855 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1856 || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1858 fail("prop_invmap('$display_prop')");
1859 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1865 elsif ($is_binary) { # These binary files don't have an explicit Y
1866 $invmap_ref->[$i] =~ s/Y//;
1869 # The file doesn't include entries that map to $missing, so don't
1870 # include it in the built-up string. But make sure that it is in
1871 # the correct order in the input.
1872 if ($invmap_ref->[$i] eq $missing) {
1873 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1874 || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1876 fail("prop_invmap('$display_prop')");
1877 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1883 # The ad property has one entry which isn't in the file.
1884 # Ignore it, but make sure it is in order.
1886 && $invmap_ref->[$i] eq '<hangul syllable>'
1887 && $invlist_ref->[$i] == 0xAC00)
1889 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1890 || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1892 fail("prop_invmap('$display_prop')");
1893 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1899 # Finally have figured out what the map column in the file should
1900 # be. Append the line to the running string.
1901 my $start = $invlist_ref->[$i];
1902 my $end = $invlist_ref->[$i+1] - 1;
1903 $end = ($start == $end) ? "" : sprintf($file_range_format, $end);
1904 if ($invmap_ref->[$i] ne "") {
1905 $tested_map .= sprintf "$file_range_format\t%s\t%s\n",
1906 $start, $end, $invmap_ref->[$i];
1908 elsif ($end ne "") {
1909 $tested_map .= sprintf "$file_range_format\t%s\n", $start, $end;
1912 $tested_map .= sprintf "$file_range_format\n", $start;
1914 } # End of looping over all elements.
1916 # Here are done with generating what the file should look like
1920 $/ = $input_record_separator;
1923 if ($tested_map ne $official) {
1924 fail_with_diff($display_prop, $official, $tested_map, "prop_invmap");
1928 # There shouldn't be any specials unaccounted for.
1929 if (keys %specials) {
1930 fail("prop_invmap('$display_prop')");
1931 diag("Unexpected specials: " . join ", ", keys %specials);
1935 elsif ($format eq 'n') {
1937 # Handle the Name property similar to the above. But the file is
1938 # sufficiently different that it is more convenient to make a special
1939 # case for it. It is a combination of the Name, Unicode1_Name, and
1940 # Name_Alias properties, and named sequences. We need to remove all
1941 # but the Name in order to do the comparison.
1943 if ($missing ne "") {
1944 fail("prop_invmap('$display_prop')");
1945 diag("The missings should be \"\"; got \"missing\"");
1949 $official = do "unicore/Name.pl";
1951 # Get rid of the named sequences portion of the file. These don't
1952 # have a tab before the first blank on a line.
1953 $official =~ s/ ^ [^\t]+ \ .*? \n //xmg;
1955 # And get rid of the controls. These are named in the file, but
1956 # shouldn't be in the property. This gets rid of the two ranges in
1957 # one fell swoop, and also all the Unicode1_Name values that may not
1959 $official =~ s/ 00000 \t .* 0001F .*? \n//xs;
1960 $official =~ s/ 0007F \t .* 0009F .*? \n//xs;
1962 # And remove the aliases. We read in the Name_Alias property, and go
1963 # through them one by one.
1964 my ($aliases_code_points, $aliases_maps, undef, undef)
1965 = &prop_invmap('Name_Alias');
1966 for (my $i = 0; $i < @$aliases_code_points; $i++) {
1967 my $code_point = $aliases_code_points->[$i];
1969 # Already removed these above.
1970 next if $code_point <= 0x1F
1971 || ($code_point >= 0x7F && $code_point <= 0x9F);
1973 my $hex_code_point = sprintf "%05X", $code_point;
1975 # Convert to a list if not already to make the following loop
1977 $aliases_maps->[$i] = [ $aliases_maps->[$i] ]
1978 if ! ref $aliases_maps->[$i];
1980 # Remove each alias for this code point from the file
1981 foreach my $alias (@{$aliases_maps->[$i]}) {
1983 # Remove the alias type from the entry, retaining just the name.
1986 $alias = quotemeta($alias);
1987 $official =~ s/$hex_code_point \t $alias \n //x;
1992 $/ = $input_record_separator;
1994 # Here have adjusted the file. We also have to adjust the returned
1995 # inversion map by checking and deleting all the lines in it that
1996 # won't be in the file. These are the lines that have generated
1997 # things, like <hangul syllable>.
1998 my $tested_map = ""; # Current running string
1999 my @code_point_in_names =
2000 @Unicode::UCD::code_points_ending_in_code_point;
2002 for my $i (0 .. @$invlist_ref - 1 - 1) {
2003 my $start = $invlist_ref->[$i];
2004 my $end = $invlist_ref->[$i+1] - 1;
2005 if ($invmap_ref->[$i] eq $missing) {
2006 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
2007 || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
2009 fail("prop_invmap('$display_prop')");
2010 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
2015 if ($invmap_ref->[$i] =~ / (.*) ( < .*? > )/x) {
2018 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
2019 || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
2021 fail("prop_invmap('$display_prop')");
2022 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
2025 if ($type eq "<hangul syllable>") {
2027 fail("prop_invmap('$display_prop')");
2028 diag("Unexpected text in $invmap_ref->[$i]");
2031 if ($start != 0xAC00) {
2032 fail("prop_invmap('$display_prop')");
2033 diag(sprintf("<hangul syllables> should begin at 0xAC00, got %04X", $start));
2036 if ($end != $start + 11172 - 1) {
2037 fail("prop_invmap('$display_prop')");
2038 diag(sprintf("<hangul syllables> should end at %04X, got %04X", $start + 11172 -1, $end));
2042 elsif ($type ne "<code point>") {
2043 fail("prop_invmap('$display_prop')");
2044 diag("Unexpected text '$type' in $invmap_ref->[$i]");
2049 # Look through the array of names that end in code points,
2050 # and look for this start and end. If not found is an
2051 # error. If found, delete it, and at the end, make sure
2052 # have deleted everything.
2053 for my $i (0 .. @code_point_in_names - 1) {
2054 my $hash = $code_point_in_names[$i];
2055 if ($hash->{'low'} == $start
2056 && $hash->{'high'} == $end
2057 && "$hash->{'name'}-" eq $name)
2059 splice @code_point_in_names, $i, 1;
2063 fail("prop_invmap('$display_prop')");
2064 diag("Unexpected code-point-in-name line '$invmap_ref->[$i]'");
2073 # Have adjusted the map, as needed. Append to running string.
2074 $end = ($start == $end) ? "" : sprintf("%05X", $end);
2075 $tested_map .= sprintf "%05X\t%s\n", $start, $invmap_ref->[$i];
2078 # Finished creating the string from the inversion map. Can compare
2079 # with what the file is.
2082 $/ = $input_record_separator;
2083 if ($tested_map ne $official) {
2084 fail_with_diff($display_prop, $official, $tested_map, "prop_invmap");
2087 if (@code_point_in_names) {
2088 fail("prop_invmap('$display_prop')");
2090 diag("Missing code-point-in-name line(s)" . Dumper \@code_point_in_names);
2094 elsif ($format eq 's') {
2096 # Here the map is not more or less directly from a file stored on
2097 # disk. We try a different tack. These should all be properties that
2098 # have just a few possible values (most of them are binary). We go
2099 # through the map list, sorting each range into buckets, one for each
2100 # map value. Thus for binary properties there will be a bucket for Y
2101 # and one for N. The buckets are inversion lists. We compare each
2102 # constructed inversion list with what we would get for it using
2103 # prop_invlist(), which has already been tested. If they all match,
2104 # the whole map must have matched.
2108 # (The extra -1 is to not look at the final element in the loop, which
2109 # we know is the one that starts just beyond Unicode and goes to
2111 for my $i (0 .. @$invlist_ref - 1 - 1) {
2112 my $range_start = $invlist_ref->[$i];
2114 # Because we are sorting into buckets, things could be
2115 # out-of-order here, and still be in the correct order in the
2116 # bucket, and hence wouldn't show up as an error; so have to
2118 if (($i > 0 && $range_start <= $invlist_ref->[$i-1])
2119 || $range_start >= $invlist_ref->[$i+1])
2121 fail("prop_invmap('$display_prop')");
2122 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
2126 # This new range closes out the range started in the previous
2128 push @{$maps{$previous_map}}, $range_start if defined $previous_map;
2130 # And starts a range which will be closed in the next iteration.
2131 $previous_map = $invmap_ref->[$i];
2132 push @{$maps{$previous_map}}, $range_start;
2135 # The range we just started hasn't been closed, and we didn't look at
2136 # the final element of the loop. If that range is for the default
2137 # value, it shouldn't be closed, as it is to extend to infinity. But
2138 # otherwise, it should end at the final Unicode code point, and the
2139 # list that maps to the default value should have another element that
2140 # does go to infinity for every above Unicode code point.
2142 if (@$invlist_ref > 1) {
2143 my $penultimate_map = $invmap_ref->[-2];
2144 if ($penultimate_map ne $missing) {
2146 # The -1th element contains the first non-Unicode code point.
2147 push @{$maps{$penultimate_map}}, $invlist_ref->[-1];
2148 push @{$maps{$missing}}, $invlist_ref->[-1];
2152 # Here, we have the buckets (inversion lists) all constructed. Go
2153 # through each and verify that matches what prop_invlist() returns.
2154 # We could use is_deeply() for the comparison, but would get multiple
2155 # messages for each $prop.
2156 foreach my $map (sort keys %maps) {
2157 my @off_invlist = prop_invlist("$prop = $map");
2158 my $min = (@off_invlist >= @{$maps{$map}})
2161 for my $i (0 .. $min- 1) {
2162 if ($i > @off_invlist - 1) {
2163 fail("prop_invmap('$display_prop')");
2164 diag("There is no element [$i] for $prop=$map from prop_invlist(), while [$i] in the implicit one constructed from prop_invmap() is '$maps{$map}[$i]'");
2167 elsif ($i > @{$maps{$map}} - 1) {
2168 fail("prop_invmap('$display_prop')");
2169 diag("There is no element [$i] from the implicit $prop=$map constructed from prop_invmap(), while [$i] in the one from prop_invlist() is '$off_invlist[$i]'");
2172 elsif ($maps{$map}[$i] ne $off_invlist[$i]) {
2173 fail("prop_invmap('$display_prop')");
2174 diag("Element [$i] of the implicit $prop=$map constructed from prop_invmap() is '$maps{$map}[$i]', and the one from prop_invlist() is '$off_invlist[$i]'");
2180 else { # Don't know this property nor format.
2182 fail("prop_invmap('$display_prop')");
2183 diag("Unknown property '$display_prop' or format '$format'");
2187 pass("prop_invmap('$display_prop')");
2190 # A few tests of search_invlist
2191 use Unicode::UCD qw(search_invlist);
2193 my ($scripts_ranges_ref, $scripts_map_ref) = prop_invmap("Script");
2194 my $index = search_invlist($scripts_ranges_ref, 0x390);
2195 is($scripts_map_ref->[$index], "Greek", "U+0390 is Greek");
2196 my @alpha_invlist = prop_invlist("Alpha");
2197 is(search_invlist(\@alpha_invlist, ord("\t")), undef, "search_invlist returns undef for code points before first one on the list");
2199 ok($/ eq $input_record_separator, "The record separator didn't get overridden");