This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert "UCD.t: Don't use BEL for $/"
[perl5.git] / lib / Unicode / UCD.t
1 #!perl -w
2 BEGIN {
3     if (ord("A") != 65) {
4         print "1..0 # Skip: EBCDIC\n";
5         exit 0;
6     }
7     chdir 't' if -d 't';
8     @INC = '../lib';
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";
12         exit 0;
13     }
14 }
15
16 use strict;
17 use Unicode::UCD;
18 use Test::More;
19
20 use Unicode::UCD 'charinfo';
21
22 $/ = 7;
23
24 my $charinfo;
25
26 is(charinfo(0x110000), undef, "Verify charinfo() of non-unicode is undef");
27
28 $charinfo = charinfo(0);    # Null is often problematic, so test it.
29
30 is($charinfo->{code},           '0000', '<control>');
31 is($charinfo->{name},           '<control>');
32 is($charinfo->{category},       'Cc');
33 is($charinfo->{combining},      '0');
34 is($charinfo->{bidi},           'BN');
35 is($charinfo->{decomposition},  '');
36 is($charinfo->{decimal},        '');
37 is($charinfo->{digit},          '');
38 is($charinfo->{numeric},        '');
39 is($charinfo->{mirrored},       'N');
40 is($charinfo->{unicode10},      'NULL');
41 is($charinfo->{comment},        '');
42 is($charinfo->{upper},          '');
43 is($charinfo->{lower},          '');
44 is($charinfo->{title},          '');
45 is($charinfo->{block},          'Basic Latin');
46 is($charinfo->{script},         'Common');
47
48 $charinfo = charinfo(0x41);
49
50 is($charinfo->{code},           '0041', 'LATIN CAPITAL LETTER A');
51 is($charinfo->{name},           'LATIN CAPITAL LETTER A');
52 is($charinfo->{category},       'Lu');
53 is($charinfo->{combining},      '0');
54 is($charinfo->{bidi},           'L');
55 is($charinfo->{decomposition},  '');
56 is($charinfo->{decimal},        '');
57 is($charinfo->{digit},          '');
58 is($charinfo->{numeric},        '');
59 is($charinfo->{mirrored},       'N');
60 is($charinfo->{unicode10},      '');
61 is($charinfo->{comment},        '');
62 is($charinfo->{upper},          '');
63 is($charinfo->{lower},          '0061');
64 is($charinfo->{title},          '');
65 is($charinfo->{block},          'Basic Latin');
66 is($charinfo->{script},         'Latin');
67
68 $charinfo = charinfo(0x100);
69
70 is($charinfo->{code},           '0100', 'LATIN CAPITAL LETTER A WITH MACRON');
71 is($charinfo->{name},           'LATIN CAPITAL LETTER A WITH MACRON');
72 is($charinfo->{category},       'Lu');
73 is($charinfo->{combining},      '0');
74 is($charinfo->{bidi},           'L');
75 is($charinfo->{decomposition},  '0041 0304');
76 is($charinfo->{decimal},        '');
77 is($charinfo->{digit},          '');
78 is($charinfo->{numeric},        '');
79 is($charinfo->{mirrored},       'N');
80 is($charinfo->{unicode10},      'LATIN CAPITAL LETTER A MACRON');
81 is($charinfo->{comment},        '');
82 is($charinfo->{upper},          '');
83 is($charinfo->{lower},          '0101');
84 is($charinfo->{title},          '');
85 is($charinfo->{block},          'Latin Extended-A');
86 is($charinfo->{script},         'Latin');
87
88 # 0x0590 is in the Hebrew block but unused.
89
90 $charinfo = charinfo(0x590);
91
92 is($charinfo->{code},          undef,   '0x0590 - unused Hebrew');
93 is($charinfo->{name},          undef);
94 is($charinfo->{category},      undef);
95 is($charinfo->{combining},     undef);
96 is($charinfo->{bidi},          undef);
97 is($charinfo->{decomposition}, undef);
98 is($charinfo->{decimal},       undef);
99 is($charinfo->{digit},         undef);
100 is($charinfo->{numeric},       undef);
101 is($charinfo->{mirrored},      undef);
102 is($charinfo->{unicode10},     undef);
103 is($charinfo->{comment},       undef);
104 is($charinfo->{upper},         undef);
105 is($charinfo->{lower},         undef);
106 is($charinfo->{title},         undef);
107 is($charinfo->{block},         undef);
108 is($charinfo->{script},        undef);
109
110 # 0x05d0 is in the Hebrew block and used.
111
112 $charinfo = charinfo(0x5d0);
113
114 is($charinfo->{code},           '05D0', '05D0 - used Hebrew');
115 is($charinfo->{name},           'HEBREW LETTER ALEF');
116 is($charinfo->{category},       'Lo');
117 is($charinfo->{combining},      '0');
118 is($charinfo->{bidi},           'R');
119 is($charinfo->{decomposition},  '');
120 is($charinfo->{decimal},        '');
121 is($charinfo->{digit},          '');
122 is($charinfo->{numeric},        '');
123 is($charinfo->{mirrored},       'N');
124 is($charinfo->{unicode10},      '');
125 is($charinfo->{comment},        '');
126 is($charinfo->{upper},          '');
127 is($charinfo->{lower},          '');
128 is($charinfo->{title},          '');
129 is($charinfo->{block},          'Hebrew');
130 is($charinfo->{script},         'Hebrew');
131
132 # An open syllable in Hangul.
133
134 $charinfo = charinfo(0xAC00);
135
136 is($charinfo->{code},           'AC00', 'HANGUL SYLLABLE U+AC00');
137 is($charinfo->{name},           'HANGUL SYLLABLE GA');
138 is($charinfo->{category},       'Lo');
139 is($charinfo->{combining},      '0');
140 is($charinfo->{bidi},           'L');
141 is($charinfo->{decomposition},  '1100 1161');
142 is($charinfo->{decimal},        '');
143 is($charinfo->{digit},          '');
144 is($charinfo->{numeric},        '');
145 is($charinfo->{mirrored},       'N');
146 is($charinfo->{unicode10},      '');
147 is($charinfo->{comment},        '');
148 is($charinfo->{upper},          '');
149 is($charinfo->{lower},          '');
150 is($charinfo->{title},          '');
151 is($charinfo->{block},          'Hangul Syllables');
152 is($charinfo->{script},         'Hangul');
153
154 # A closed syllable in Hangul.
155
156 $charinfo = charinfo(0xAE00);
157
158 is($charinfo->{code},           'AE00', 'HANGUL SYLLABLE U+AE00');
159 is($charinfo->{name},           'HANGUL SYLLABLE GEUL');
160 is($charinfo->{category},       'Lo');
161 is($charinfo->{combining},      '0');
162 is($charinfo->{bidi},           'L');
163 is($charinfo->{decomposition},  "1100 1173 11AF");
164 is($charinfo->{decimal},        '');
165 is($charinfo->{digit},          '');
166 is($charinfo->{numeric},        '');
167 is($charinfo->{mirrored},       'N');
168 is($charinfo->{unicode10},      '');
169 is($charinfo->{comment},        '');
170 is($charinfo->{upper},          '');
171 is($charinfo->{lower},          '');
172 is($charinfo->{title},          '');
173 is($charinfo->{block},          'Hangul Syllables');
174 is($charinfo->{script},         'Hangul');
175
176 $charinfo = charinfo(0x1D400);
177
178 is($charinfo->{code},           '1D400', 'MATHEMATICAL BOLD CAPITAL A');
179 is($charinfo->{name},           'MATHEMATICAL BOLD CAPITAL A');
180 is($charinfo->{category},       'Lu');
181 is($charinfo->{combining},      '0');
182 is($charinfo->{bidi},           'L');
183 is($charinfo->{decomposition},  '<font> 0041');
184 is($charinfo->{decimal},        '');
185 is($charinfo->{digit},          '');
186 is($charinfo->{numeric},        '');
187 is($charinfo->{mirrored},       'N');
188 is($charinfo->{unicode10},      '');
189 is($charinfo->{comment},        '');
190 is($charinfo->{upper},          '');
191 is($charinfo->{lower},          '');
192 is($charinfo->{title},          '');
193 is($charinfo->{block},          'Mathematical Alphanumeric Symbols');
194 is($charinfo->{script},         'Common');
195
196 $charinfo = charinfo(0x9FBA);   #Bug 58428
197
198 is($charinfo->{code},           '9FBA', 'U+9FBA');
199 is($charinfo->{name},           'CJK UNIFIED IDEOGRAPH-9FBA');
200 is($charinfo->{category},       'Lo');
201 is($charinfo->{combining},      '0');
202 is($charinfo->{bidi},           'L');
203 is($charinfo->{decomposition},  '');
204 is($charinfo->{decimal},        '');
205 is($charinfo->{digit},          '');
206 is($charinfo->{numeric},        '');
207 is($charinfo->{mirrored},       'N');
208 is($charinfo->{unicode10},      '');
209 is($charinfo->{comment},        '');
210 is($charinfo->{upper},          '');
211 is($charinfo->{lower},          '');
212 is($charinfo->{title},          '');
213 is($charinfo->{block},          'CJK Unified Ideographs');
214 is($charinfo->{script},         'Han');
215
216 use Unicode::UCD qw(charblock charscript);
217
218 # 0x0590 is in the Hebrew block but unused.
219
220 is(charblock(0x590),          'Hebrew', '0x0590 - Hebrew unused charblock');
221 is(charscript(0x590),         'Unknown',    '0x0590 - Hebrew unused charscript');
222 is(charblock(0x1FFFF),        'No_Block', '0x1FFFF - unused charblock');
223
224 $charinfo = charinfo(0xbe);
225
226 is($charinfo->{code},           '00BE', 'VULGAR FRACTION THREE QUARTERS');
227 is($charinfo->{name},           'VULGAR FRACTION THREE QUARTERS');
228 is($charinfo->{category},       'No');
229 is($charinfo->{combining},      '0');
230 is($charinfo->{bidi},           'ON');
231 is($charinfo->{decomposition},  '<fraction> 0033 2044 0034');
232 is($charinfo->{decimal},        '');
233 is($charinfo->{digit},          '');
234 is($charinfo->{numeric},        '3/4');
235 is($charinfo->{mirrored},       'N');
236 is($charinfo->{unicode10},      'FRACTION THREE QUARTERS');
237 is($charinfo->{comment},        '');
238 is($charinfo->{upper},          '');
239 is($charinfo->{lower},          '');
240 is($charinfo->{title},          '');
241 is($charinfo->{block},          'Latin-1 Supplement');
242 is($charinfo->{script},         'Common');
243
244 # This is to test a case where both simple and full lowercases exist and
245 # differ
246 $charinfo = charinfo(0x130);
247
248 is($charinfo->{code},           '0130', 'LATIN CAPITAL LETTER I WITH DOT ABOVE');
249 is($charinfo->{name},           'LATIN CAPITAL LETTER I WITH DOT ABOVE');
250 is($charinfo->{category},       'Lu');
251 is($charinfo->{combining},      '0');
252 is($charinfo->{bidi},           'L');
253 is($charinfo->{decomposition},  '0049 0307');
254 is($charinfo->{decimal},        '');
255 is($charinfo->{digit},          '');
256 is($charinfo->{numeric},        '');
257 is($charinfo->{mirrored},       'N');
258 is($charinfo->{unicode10},      'LATIN CAPITAL LETTER I DOT');
259 is($charinfo->{comment},        '');
260 is($charinfo->{upper},          '');
261 is($charinfo->{lower},          '0069');
262 is($charinfo->{title},          '');
263 is($charinfo->{block},          'Latin Extended-A');
264 is($charinfo->{script},         'Latin');
265
266 # This is to test a case where both simple and full uppercases exist and
267 # differ
268 $charinfo = charinfo(0x1F80);
269
270 is($charinfo->{code},           '1F80', 'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
271 is($charinfo->{name},           'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
272 is($charinfo->{category},       'Ll');
273 is($charinfo->{combining},      '0');
274 is($charinfo->{bidi},           'L');
275 is($charinfo->{decomposition},  '1F00 0345');
276 is($charinfo->{decimal},        '');
277 is($charinfo->{digit},          '');
278 is($charinfo->{numeric},        '');
279 is($charinfo->{mirrored},       'N');
280 is($charinfo->{unicode10},      '');
281 is($charinfo->{comment},        '');
282 is($charinfo->{upper},          '1F88');
283 is($charinfo->{lower},          '');
284 is($charinfo->{title},          '1F88');
285 is($charinfo->{block},          'Greek Extended');
286 is($charinfo->{script},         'Greek');
287
288 use Unicode::UCD qw(charblocks charscripts);
289
290 my $charblocks = charblocks();
291
292 ok(exists $charblocks->{Thai}, 'Thai charblock exists');
293 is($charblocks->{Thai}->[0]->[0], hex('0e00'));
294 ok(!exists $charblocks->{PigLatin}, 'PigLatin charblock does not exist');
295
296 my $charscripts = charscripts();
297
298 ok(exists $charscripts->{Armenian}, 'Armenian charscript exists');
299 is($charscripts->{Armenian}->[0]->[0], hex('0531'));
300 ok(!exists $charscripts->{PigLatin}, 'PigLatin charscript does not exist');
301
302 my $charscript;
303
304 $charscript = charscript("12ab");
305 is($charscript, 'Ethiopic', 'Ethiopic charscript');
306
307 $charscript = charscript("0x12ab");
308 is($charscript, 'Ethiopic');
309
310 $charscript = charscript("U+12ab");
311 is($charscript, 'Ethiopic');
312
313 my $ranges;
314
315 $ranges = charscript('Ogham');
316 is($ranges->[0]->[0], hex('1680'), 'Ogham charscript');
317 is($ranges->[0]->[1], hex('169C'));
318
319 use Unicode::UCD qw(charinrange);
320
321 $ranges = charscript('Cherokee');
322 ok(!charinrange($ranges, "139f"), 'Cherokee charscript');
323 ok( charinrange($ranges, "13a0"));
324 ok( charinrange($ranges, "13f4"));
325 ok(!charinrange($ranges, "13f5"));
326
327 use Unicode::UCD qw(general_categories);
328
329 my $gc = general_categories();
330
331 ok(exists $gc->{L}, 'has L');
332 is($gc->{L}, 'Letter', 'L is Letter');
333 is($gc->{Lu}, 'UppercaseLetter', 'Lu is UppercaseLetter');
334
335 use Unicode::UCD qw(bidi_types);
336
337 my $bt = bidi_types();
338
339 ok(exists $bt->{L}, 'has L');
340 is($bt->{L}, 'Left-to-Right', 'L is Left-to-Right');
341 is($bt->{AL}, 'Right-to-Left Arabic', 'AL is Right-to-Left Arabic');
342
343 # If this fails, then maybe one should look at the Unicode changes to see
344 # what else might need to be updated.
345 is(Unicode::UCD::UnicodeVersion, '6.1.0', 'UnicodeVersion');
346
347 use Unicode::UCD qw(compexcl);
348
349 ok(!compexcl(0x0100), 'compexcl');
350 ok(!compexcl(0xD801), 'compexcl of surrogate');
351 ok(!compexcl(0x110000), 'compexcl of non-Unicode code point');
352 ok( compexcl(0x0958));
353
354 use Unicode::UCD qw(casefold);
355
356 my $casefold;
357
358 $casefold = casefold(0x41);
359
360 is($casefold->{code}, '0041', 'casefold 0x41 code');
361 is($casefold->{status}, 'C', 'casefold 0x41 status');
362 is($casefold->{mapping}, '0061', 'casefold 0x41 mapping');
363 is($casefold->{full}, '0061', 'casefold 0x41 full');
364 is($casefold->{simple}, '0061', 'casefold 0x41 simple');
365 is($casefold->{turkic}, "", 'casefold 0x41 turkic');
366
367 $casefold = casefold(0xdf);
368
369 is($casefold->{code}, '00DF', 'casefold 0xDF code');
370 is($casefold->{status}, 'F', 'casefold 0xDF status');
371 is($casefold->{mapping}, '0073 0073', 'casefold 0xDF mapping');
372 is($casefold->{full}, '0073 0073', 'casefold 0xDF full');
373 is($casefold->{simple}, "", 'casefold 0xDF simple');
374 is($casefold->{turkic}, "", 'casefold 0xDF turkic');
375
376 # Do different tests depending on if version < 3.2, or not.
377 my $v_unicode_version = pack "C*", split /\./, Unicode::UCD::UnicodeVersion();
378 if ($v_unicode_version lt v3.2.0) {
379         $casefold = casefold(0x130);
380
381         is($casefold->{code}, '0130', 'casefold 0x130 code');
382         is($casefold->{status}, 'I' , 'casefold 0x130 status');
383         is($casefold->{mapping}, '0069', 'casefold 0x130 mapping');
384         is($casefold->{full}, '0069', 'casefold 0x130 full');
385         is($casefold->{simple}, "0069", 'casefold 0x130 simple');
386         is($casefold->{turkic}, "0069", 'casefold 0x130 turkic');
387
388         $casefold = casefold(0x131);
389
390         is($casefold->{code}, '0131', 'casefold 0x131 code');
391         is($casefold->{status}, 'I' , 'casefold 0x131 status');
392         is($casefold->{mapping}, '0069', 'casefold 0x131 mapping');
393         is($casefold->{full}, '0069', 'casefold 0x131 full');
394         is($casefold->{simple}, "0069", 'casefold 0x131 simple');
395         is($casefold->{turkic}, "0069", 'casefold 0x131 turkic');
396 } else {
397         $casefold = casefold(0x49);
398
399         is($casefold->{code}, '0049', 'casefold 0x49 code');
400         is($casefold->{status}, 'C' , 'casefold 0x49 status');
401         is($casefold->{mapping}, '0069', 'casefold 0x49 mapping');
402         is($casefold->{full}, '0069', 'casefold 0x49 full');
403         is($casefold->{simple}, "0069", 'casefold 0x49 simple');
404         is($casefold->{turkic}, "0131", 'casefold 0x49 turkic');
405
406         $casefold = casefold(0x130);
407
408         is($casefold->{code}, '0130', 'casefold 0x130 code');
409         is($casefold->{status}, 'F' , 'casefold 0x130 status');
410         is($casefold->{mapping}, '0069 0307', 'casefold 0x130 mapping');
411         is($casefold->{full}, '0069 0307', 'casefold 0x130 full');
412         is($casefold->{simple}, "", 'casefold 0x130 simple');
413         is($casefold->{turkic}, "0069", 'casefold 0x130 turkic');
414 }
415
416 $casefold = casefold(0x1F88);
417
418 is($casefold->{code}, '1F88', 'casefold 0x1F88 code');
419 is($casefold->{status}, 'S' , 'casefold 0x1F88 status');
420 is($casefold->{mapping}, '1F80', 'casefold 0x1F88 mapping');
421 is($casefold->{full}, '1F00 03B9', 'casefold 0x1F88 full');
422 is($casefold->{simple}, '1F80', 'casefold 0x1F88 simple');
423 is($casefold->{turkic}, "", 'casefold 0x1F88 turkic');
424
425 ok(!casefold(0x20));
426
427 use Unicode::UCD qw(casespec);
428
429 my $casespec;
430
431 ok(!casespec(0x41));
432
433 $casespec = casespec(0xdf);
434
435 ok($casespec->{code} eq '00DF' &&
436    $casespec->{lower} eq '00DF'  &&
437    $casespec->{title} eq '0053 0073'  &&
438    $casespec->{upper} eq '0053 0053' &&
439    !defined $casespec->{condition}, 'casespec 0xDF');
440
441 $casespec = casespec(0x307);
442
443 ok($casespec->{az}->{code} eq '0307' &&
444    !defined $casespec->{az}->{lower} &&
445    $casespec->{az}->{title} eq '0307'  &&
446    $casespec->{az}->{upper} eq '0307' &&
447    $casespec->{az}->{condition} eq 'az After_I',
448    'casespec 0x307');
449
450 # perl #7305 UnicodeCD::compexcl is weird
451
452 for (1) {my $a=compexcl $_}
453 ok(1, 'compexcl read-only $_: perl #7305');
454 map {compexcl $_} %{{1=>2}};
455 ok(1, 'compexcl read-only hash: perl #7305');
456
457 is(Unicode::UCD::_getcode('123'),     123, "_getcode(123)");
458 is(Unicode::UCD::_getcode('0123'),  0x123, "_getcode(0123)");
459 is(Unicode::UCD::_getcode('0x123'), 0x123, "_getcode(0x123)");
460 is(Unicode::UCD::_getcode('0X123'), 0x123, "_getcode(0X123)");
461 is(Unicode::UCD::_getcode('U+123'), 0x123, "_getcode(U+123)");
462 is(Unicode::UCD::_getcode('u+123'), 0x123, "_getcode(u+123)");
463 is(Unicode::UCD::_getcode('U+1234'),   0x1234, "_getcode(U+1234)");
464 is(Unicode::UCD::_getcode('U+12345'), 0x12345, "_getcode(U+12345)");
465 is(Unicode::UCD::_getcode('123x'),    undef, "_getcode(123x)");
466 is(Unicode::UCD::_getcode('x123'),    undef, "_getcode(x123)");
467 is(Unicode::UCD::_getcode('0x123x'),  undef, "_getcode(x123)");
468 is(Unicode::UCD::_getcode('U+123x'),  undef, "_getcode(x123)");
469
470 {
471     my $r1 = charscript('Latin');
472     if (ok(defined $r1, "Found Latin script")) {
473         my $n1 = @$r1;
474         is($n1, 30, "number of ranges in Latin script (Unicode 6.1.0)");
475         shift @$r1 while @$r1;
476         my $r2 = charscript('Latin');
477         is(@$r2, $n1, "modifying results should not mess up internal caches");
478     }
479 }
480
481 {
482         is(charinfo(0xdeadbeef), undef, "[perl #23273] warnings in Unicode::UCD");
483 }
484
485 use Unicode::UCD qw(namedseq);
486
487 is(namedseq("KATAKANA LETTER AINU P"), "\x{31F7}\x{309A}", "namedseq");
488 is(namedseq("KATAKANA LETTER AINU Q"), undef);
489 is(namedseq(), undef);
490 is(namedseq(qw(foo bar)), undef);
491 my @ns = namedseq("KATAKANA LETTER AINU P");
492 is(scalar @ns, 2);
493 is($ns[0], 0x31F7);
494 is($ns[1], 0x309A);
495 my %ns = namedseq();
496 is($ns{"KATAKANA LETTER AINU P"}, "\x{31F7}\x{309A}");
497 @ns = namedseq(42);
498 is(@ns, 0);
499
500 use Unicode::UCD qw(num);
501 use charnames ":full";
502
503 is(num("0"), 0, 'Verify num("0") == 0');
504 is(num("98765"), 98765, 'Verify num("98765") == 98765');
505 ok(! defined num("98765\N{FULLWIDTH DIGIT FOUR}"), 'Verify num("98765\N{FULLWIDTH DIGIT FOUR}") isnt defined');
506 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');
507 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');
508 is(num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}"), 3, 'Verify num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}") == 3');
509 ok(! defined num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}"), 'Verify num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}") isnt defined');
510 is(num("\N{SUPERSCRIPT TWO}"), 2, 'Verify num("\N{SUPERSCRIPT TWO} == 2');
511 is(num("\N{ETHIOPIC NUMBER TEN THOUSAND}"), 10000, 'Verify num("\N{ETHIOPIC NUMBER TEN THOUSAND}") == 10000');
512 is(num("\N{NORTH INDIC FRACTION ONE HALF}"), .5, 'Verify num("\N{NORTH INDIC FRACTION ONE HALF}") == .5');
513 is(num("\N{U+12448}"), 9, 'Verify num("\N{U+12448}") == 9');
514 is(num("\N{U+5146}"), 1000000000000, 'Verify num("\N{U+5146}") == 1000000000000');
515
516 # Create a user-defined property
517 sub InKana {<<'END'}
518 3040    309F
519 30A0    30FF
520 END
521
522 use Unicode::UCD qw(prop_aliases);
523
524 is(prop_aliases(undef), undef, "prop_aliases(undef) returns <undef>");
525 is(prop_aliases("unknown property"), undef,
526                 "prop_aliases(<unknown property>) returns <undef>");
527 is(prop_aliases("InKana"), undef,
528                 "prop_aliases(<user-defined property>) returns <undef>");
529 is(prop_aliases("Perl_Decomposition_Mapping"), undef, "prop_aliases('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
530 is(prop_aliases("Perl_Charnames"), undef,
531     "prop_aliases('Perl_Charnames') returns <undef> since internal-Perl-only");
532 is(prop_aliases("isgc"), undef,
533     "prop_aliases('isgc') returns <undef> since is not covered Perl extension");
534 is(prop_aliases("Is_Is_Any"), undef,
535                 "prop_aliases('Is_Is_Any') returns <undef> since two is's");
536
537 require 'utf8_heavy.pl';
538 require "unicore/Heavy.pl";
539
540 # Keys are lists of properties. Values are defined if have been tested.
541 my %props;
542
543 # To test for loose matching, add in the characters that are ignored there.
544 my $extra_chars = "-_ ";
545
546 # The one internal property we accept
547 $props{'Perl_Decimal_Digit'} = 1;
548 my @list = prop_aliases("perldecimaldigit");
549 is_deeply(\@list,
550           [ "Perl_Decimal_Digit",
551             "Perl_Decimal_Digit"
552           ], "prop_aliases('perldecimaldigit') returns Perl_Decimal_Digit as both short and full names");
553
554 # Get the official Unicode property name synonyms and test them.
555
556 SKIP: {
557 skip "PropertyAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
558 open my $props, "<", "../lib/unicore/PropertyAliases.txt"
559                 or die "Can't open Unicode PropertyAliases.txt";
560 $/ = "\n";
561 while (<$props>) {
562     s/\s*#.*//;           # Remove comments
563     next if /^\s* $/x;    # Ignore empty and comment lines
564
565     chomp;
566     my $count = 0;  # 0th field in line is short name; 1th is long name
567     my $short_name;
568     my $full_name;
569     my @names_via_short;
570     foreach my $alias (split /\s*;\s*/) {    # Fields are separated by
571                                              # semi-colons
572         # Add in the characters that are supposed to be ignored, to test loose
573         # matching, which the tested function does on all inputs.
574         my $mod_name = "$extra_chars$alias";
575
576         my $loose = &utf8::_loose_name(lc $alias);
577
578         # Indicate we have tested this.
579         $props{$loose} = 1;
580
581         my @all_names = prop_aliases($mod_name);
582         if (grep { $_ eq $loose } @Unicode::UCD::suppressed_properties) {
583             is(@all_names, 0, "prop_aliases('$mod_name') returns undef since $alias is not installed");
584             next;
585         }
586         elsif (! @all_names) {
587             fail("prop_aliases('$mod_name')");
588             diag("'$alias' is unknown to prop_aliases()");
589             next;
590         }
591
592         if ($count == 0) {  # Is short name
593
594             @names_via_short = prop_aliases($mod_name);
595
596             # If the 0th test fails, no sense in continuing with the others
597             last unless is($names_via_short[0], $alias,
598                     "prop_aliases: '$alias' is the short name for '$mod_name'");
599             $short_name = $alias;
600         }
601         elsif ($count == 1) {   # Is full name
602
603             # Some properties have the same short and full name; no sense
604             # repeating the test if the same.
605             if ($alias ne $short_name) {
606                 my @names_via_full = prop_aliases($mod_name);
607                 is_deeply(\@names_via_full, \@names_via_short, "prop_aliases() returns the same list for both '$short_name' and '$mod_name'");
608             }
609
610             # Tests scalar context
611             is(prop_aliases($short_name), $alias,
612                 "prop_aliases: '$alias' is the long name for '$short_name'");
613         }
614         else {  # Is another alias
615             is_deeply(\@all_names, \@names_via_short, "prop_aliases() returns the same list for both '$short_name' and '$mod_name'");
616             ok((grep { $_ =~ /^$alias$/i } @all_names),
617                 "prop_aliases: '$alias' is listed as an alias for '$mod_name'");
618         }
619
620         $count++;
621     }
622 }
623 } # End of SKIP block
624
625 # Now test anything we can find that wasn't covered by the tests of the
626 # official properties.  We have no way of knowing if mktables omitted a Perl
627 # extension or not, but we do the best we can from its generated lists
628
629 foreach my $alias (keys %utf8::loose_to_file_of) {
630     next if $alias =~ /=/;
631     my $lc_name = lc $alias;
632     my $loose = &utf8::_loose_name($lc_name);
633     next if exists $props{$loose};  # Skip if already tested
634     $props{$loose} = 1;
635     my $mod_name = "$extra_chars$alias";    # Tests loose matching
636     my @aliases = prop_aliases($mod_name);
637     my $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
638     if ($found_it) {
639         pass("prop_aliases: '$lc_name' is listed as an alias for '$mod_name'");
640     }
641     elsif ($lc_name =~ /l[_&]$/) {
642
643         # These two names are special in that they don't appear in the
644         # returned list because they are discouraged from use.  Verify
645         # that they return the same list as a non-discouraged version.
646         my @LC = prop_aliases('Is_LC');
647         is_deeply(\@aliases, \@LC, "prop_aliases: '$lc_name' returns the same list as 'Is_LC'");
648     }
649     else {
650         my $stripped = $lc_name =~ s/^is//;
651
652         # Could be that the input includes a prefix 'is', which is rarely
653         # returned as an alias, so having successfully stripped it off above,
654         # try again.
655         if ($stripped) {
656             $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
657         }
658
659         # If that didn't work, it could be that it's a block, which is always
660         # returned with a leading 'In_' to avoid ambiguity.  Try comparing
661         # with that stripped off.
662         if (! $found_it) {
663             $found_it = grep { &utf8::_loose_name(s/^In_(.*)/\L$1/r) eq $lc_name }
664                               @aliases;
665             # Could check that is a real block, but tests for invmap will
666             # likely pickup any errors, since this will be tested there.
667             $lc_name = "in$lc_name" if $found_it;   # Change for message below
668         }
669         my $message = "prop_aliases: '$lc_name' is listed as an alias for '$mod_name'";
670         ($found_it) ? pass($message) : fail($message);
671     }
672 }
673
674 my $done_equals = 0;
675 foreach my $alias (keys %utf8::stricter_to_file_of) {
676     if ($alias =~ /=/) {    # Only test one case where there is an equals
677         next if $done_equals;
678         $done_equals = 1;
679     }
680     my $lc_name = lc $alias;
681     my @list = prop_aliases($alias);
682     if ($alias =~ /^_/) {
683         is(@list, 0, "prop_aliases: '$lc_name' returns an empty list since it is internal_only");
684     }
685     elsif ($alias =~ /=/) {
686         is(@list, 0, "prop_aliases: '$lc_name' returns an empty list since is illegal property name");
687     }
688     else {
689         ok((grep { lc $_ eq $lc_name } @list),
690                 "prop_aliases: '$lc_name' is listed as an alias for '$alias'");
691     }
692 }
693
694 use Unicode::UCD qw(prop_value_aliases);
695
696 is(prop_value_aliases("unknown property", "unknown value"), undef,
697     "prop_value_aliases(<unknown property>, <unknown value>) returns <undef>");
698 is(prop_value_aliases(undef, undef), undef,
699                            "prop_value_aliases(undef, undef) returns <undef>");
700 is((prop_value_aliases("na", "A")), "A", "test that prop_value_aliases returns its input for properties that don't have synonyms");
701 is(prop_value_aliases("isgc", "C"), undef, "prop_value_aliases('isgc', 'C') returns <undef> since is not covered Perl extension");
702 is(prop_value_aliases("gc", "isC"), undef, "prop_value_aliases('gc', 'isC') returns <undef> since is not covered Perl extension");
703
704 # We have no way of knowing if mktables omitted a Perl extension that it
705 # shouldn't have, but we can check if it omitted an official Unicode property
706 # name synonym.  And for those, we can check if the short and full names are
707 # correct.
708
709 my %pva_tested;   # List of things already tested.
710
711 SKIP: {
712 skip "PropValueAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
713 open my $propvalues, "<", "../lib/unicore/PropValueAliases.txt"
714      or die "Can't open Unicode PropValueAliases.txt";
715 while (<$propvalues>) {
716     s/\s*#.*//;           # Remove comments
717     next if /^\s* $/x;    # Ignore empty and comment lines
718     chomp;
719
720     # Fix typo in official input file
721     s/CCC133/CCC132/g if $v_unicode_version eq v6.1.0;
722
723     my @fields = split /\s*;\s*/; # Fields are separated by semi-colons
724     my $prop = shift @fields;   # 0th field is the property,
725     my $count = 0;  # 0th field in line (after shifting off the property) is
726                     # short name; 1th is long name
727     my $short_name;
728     my @names_via_short;    # Saves the values between iterations
729
730     # The property on the lhs of the = is always loosely matched.  Add in
731     # characters that are ignored under loose matching to test that
732     my $mod_prop = "$extra_chars$prop";
733
734     if ($fields[0] eq 'n/a') {  # See comments in input file, essentially
735                                 # means full name and short name are identical
736         $fields[0] = $fields[1];
737     }
738     elsif ($fields[0] ne $fields[1]
739            && &utf8::_loose_name(lc $fields[0])
740                eq &utf8::_loose_name(lc $fields[1])
741            && $fields[1] !~ /[[:upper:]]/)
742     {
743         # Also, there is a bug in the file in which "n/a" is omitted, and
744         # the two fields are identical except for case, and the full name
745         # is all lower case.  Copy the "short" name unto the full one to
746         # give it some upper case.
747
748         $fields[1] = $fields[0];
749     }
750
751     # The ccc property in the file is special; has an extra numeric field
752     # (0th), which should go at the end, since we use the next two fields as
753     # the short and full names, respectively.  See comments in input file.
754     splice (@fields, 0, 0, splice(@fields, 1, 2)) if $prop eq 'ccc';
755
756     my $loose_prop = &utf8::_loose_name(lc $prop);
757     my $suppressed = grep { $_ eq $loose_prop }
758                           @Unicode::UCD::suppressed_properties;
759     foreach my $value (@fields) {
760         if ($suppressed) {
761             is(prop_value_aliases($prop, $value), undef, "prop_value_aliases('$prop', '$value') returns undef for suppressed property $prop");
762             next;
763         }
764         elsif (grep { $_ eq ("$loose_prop=" . &utf8::_loose_name(lc $value)) } @Unicode::UCD::suppressed_properties) {
765             is(prop_value_aliases($prop, $value), undef, "prop_value_aliases('$prop', '$value') returns undef for suppressed property $prop=$value");
766             next;
767         }
768
769         # Add in test for loose matching.
770         my $mod_value = "$extra_chars$value";
771
772         # If the value is a number, optionally negative, including a floating
773         # point or rational numer, it should be only strictly matched, so the
774         # loose matching should fail.
775         if ($value =~ / ^ -? \d+ (?: [\/.] \d+ )? $ /x) {
776             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");
777
778             # And reset so below tests just the strict matching.
779             $mod_value = $value;
780         }
781
782         if ($count == 0) {
783
784             @names_via_short = prop_value_aliases($mod_prop, $mod_value);
785
786             # If the 0th test fails, no sense in continuing with the others
787             last unless is($names_via_short[0], $value, "prop_value_aliases: In '$prop', '$value' is the short name for '$mod_value'");
788             $short_name = $value;
789         }
790         elsif ($count == 1) {
791
792             # Some properties have the same short and full name; no sense
793             # repeating the test if the same.
794             if ($value ne $short_name) {
795                 my @names_via_full =
796                             prop_value_aliases($mod_prop, $mod_value);
797                 is_deeply(\@names_via_full, \@names_via_short, "In '$prop', prop_value_aliases() returns the same list for both '$short_name' and '$mod_value'");
798             }
799
800             # Tests scalar context
801             is(prop_value_aliases($prop, $short_name), $value, "'$value' is the long name for prop_value_aliases('$prop', '$short_name')");
802         }
803         else {
804             my @all_names = prop_value_aliases($mod_prop, $mod_value);
805             is_deeply(\@all_names, \@names_via_short, "In '$prop', prop_value_aliases() returns the same list for both '$short_name' and '$mod_value'");
806             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')");
807         }
808
809         $pva_tested{&utf8::_loose_name(lc $prop) . "=" . &utf8::_loose_name(lc $value)} = 1;
810         $count++;
811     }
812 }
813 }   # End of SKIP block
814
815 # And test as best we can, the non-official pva's that mktables generates.
816 foreach my $hash (\%utf8::loose_to_file_of, \%utf8::stricter_to_file_of) {
817     foreach my $test (keys %$hash) {
818         next if exists $pva_tested{$test};  # Skip if already tested
819
820         my ($prop, $value) = split "=", $test;
821         next unless defined $value; # prop_value_aliases() requires an input
822                                     # 'value'
823         my $mod_value;
824         if ($hash == \%utf8::loose_to_file_of) {
825
826             # Add extra characters to test loose-match rhs value
827             $mod_value = "$extra_chars$value";
828         }
829         else { # Here value is strictly matched.
830
831             # Extra elements are added by mktables to this hash so that
832             # something like "age=6.0" has a synonym of "age=6".  It's not
833             # clear to me (khw) if we should be encouraging those synonyms, so
834             # don't test for them.
835             next if $value !~ /\D/ && exists $hash->{"$prop=$value.0"};
836
837             # Verify that loose matching fails when only strict is called for.
838             next unless is(prop_value_aliases($prop, "$extra_chars$value"), undef,
839                         "prop_value_aliases('$prop', '$extra_chars$value') returns undef since '$value' should be strictly matched"),
840
841             # Strict matching does allow for underscores between digits.  Test
842             # for that.
843             $mod_value = $value;
844             while ($mod_value =~ s/(\d)(\d)/$1_$2/g) {}
845         }
846
847         # The lhs property is always loosely matched, so add in extra
848         # characters to test that.
849         my $mod_prop = "$extra_chars$prop";
850
851         if ($prop eq 'gc' && $value =~ /l[_&]$/) {
852             # These two names are special in that they don't appear in the
853             # returned list because they are discouraged from use.  Verify
854             # that they return the same list as a non-discouraged version.
855             my @LC = prop_value_aliases('gc', 'lc');
856             my @l_ = prop_value_aliases($mod_prop, $mod_value);
857             is_deeply(\@l_, \@LC, "prop_value_aliases('$mod_prop', '$mod_value) returns the same list as prop_value_aliases('gc', 'lc')");
858         }
859         else {
860             ok((grep { &utf8::_loose_name(lc $_) eq &utf8::_loose_name(lc $value) }
861                 prop_value_aliases($mod_prop, $mod_value)),
862                 "'$value' is listed as an alias for prop_value_aliases('$mod_prop', '$mod_value')");
863         }
864     }
865 }
866
867 undef %pva_tested;
868
869 no warnings 'once'; # We use some values once from 'required' modules.
870
871 use Unicode::UCD qw(prop_invlist prop_invmap MAX_CP);
872
873 # There were some problems with caching interfering with prop_invlist() vs
874 # prop_invmap() on binary properties, and also between the 3 properties where
875 # Perl used the same 'To' name as another property (see utf8_heavy.pl).
876 # So, before testing all of prop_invlist(),
877 #   1)  call prop_invmap() to try both orders of these name issues.  This uses
878 #       up two of the 3 properties;  the third will be left so that invlist()
879 #       on it gets called before invmap()
880 #   2)  call prop_invmap() on a generic binary property, ahead of invlist().
881 # This should test that the caching works in both directions.
882
883 # These properties are not stable between Unicode versions, but the first few
884 # elements are; just look at the first element to see if are getting the
885 # distinction right.  The general inversion map testing below will test the
886 # whole thing.
887 my $prop = "uc";
888 my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
889 is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
890 is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
891 is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
892 is($invmap_ref->[1], 0x41, "prop_invmap('$prop') map[1] is 0x41");
893
894 $prop = "upper";
895 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
896 is($format, 's', "prop_invmap() format of '$prop' is 's");
897 is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
898 is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
899 is($invmap_ref->[1], 'Y', "prop_invmap('$prop') map[1] is 'Y'");
900
901 $prop = "lower";
902 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
903 is($format, 's', "prop_invmap() format of '$prop' is 's'");
904 is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
905 is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
906 is($invmap_ref->[1], 'Y', "prop_invmap('$prop') map[1] is 'Y'");
907
908 $prop = "lc";
909 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
910 is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
911 is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
912 is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
913 is($invmap_ref->[1], 0x61, "prop_invmap('$prop') map[1] is 0x61");
914
915 # This property is stable and small, so can test all of it
916 $prop = "ASCII_Hex_Digit";
917 ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
918 is($format, 's', "prop_invmap() format of '$prop' is 's'");
919 is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
920 is_deeply($invlist_ref, [ 0x0000, 0x0030, 0x003A, 0x0041,
921                           0x0047, 0x0061, 0x0067, 0x110000 ],
922           "prop_invmap('$prop') code point list is correct");
923 is_deeply($invmap_ref, [ 'N', 'Y', 'N', 'Y', 'N', 'Y', 'N', 'N' ] ,
924           "prop_invmap('$prop') map list is correct");
925
926 is(prop_invlist("Unknown property"), undef, "prop_invlist(<Unknown property>) returns undef");
927 is(prop_invlist(undef), undef, "prop_invlist(undef) returns undef");
928 is(prop_invlist("Any"), 2, "prop_invlist('Any') returns the number of elements in scalar context");
929 my @invlist = prop_invlist("Is_Any");
930 is_deeply(\@invlist, [ 0, 0x110000 ], "prop_invlist works on 'Is_' prefixes");
931 is(prop_invlist("Is_Is_Any"), undef, "prop_invlist('Is_Is_Any') returns <undef> since two is's");
932
933 use Storable qw(dclone);
934
935 is(prop_invlist("InKana"), undef, "prop_invlist(<user-defined property returns undef>)");
936
937 # The way both the tests for invlist and invmap work is that they take the
938 # lists returned by the functions and construct from them what the original
939 # file should look like, which are then compared with the file.  If they are
940 # identical, the test passes.  What this tests isn't that the results are
941 # correct, but that invlist and invmap haven't introduced errors beyond what
942 # are there in the files.  As a small hedge against that, test some
943 # prop_invlist() tables fully with the known correct result.  We choose
944 # ASCII_Hex_Digit again, as it is stable.
945 @invlist = prop_invlist("AHex");
946 is_deeply(\@invlist, [ 0x0030, 0x003A, 0x0041,
947                                  0x0047, 0x0061, 0x0067 ],
948           "prop_invlist('AHex') is exactly the expected set of points");
949 @invlist = prop_invlist("AHex=f");
950 is_deeply(\@invlist, [ 0x0000, 0x0030, 0x003A, 0x0041,
951                                  0x0047, 0x0061, 0x0067 ],
952           "prop_invlist('AHex=f') is exactly the expected set of points");
953
954 sub fail_with_diff ($$$$) {
955     # For use below to output better messages
956     my ($prop, $official, $constructed, $tested_function_name) = @_;
957
958     is($constructed, $official, "$tested_function_name('$prop')");
959     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");
960     return;
961
962     fail("$tested_function_name('$prop')");
963
964     require File::Temp;
965     my $off = File::Temp->new();
966     chomp $official;
967     print $off $official, "\n";
968     close $off || die "Can't close official";
969
970     chomp $constructed;
971     my $gend = File::Temp->new();
972     print $gend $constructed, "\n";
973     close $gend || die "Can't close gend";
974
975     my $diff = File::Temp->new();
976     system("diff $off $gend > $diff");
977
978     open my $fh, "<", $diff || die "Can't open $diff";
979     my @diffs = <$fh>;
980     diag("In the diff output below '<' marks lines from the filesystem tables;\n'>' are from $tested_function_name()");
981     diag(@diffs);
982 }
983
984 my %tested_invlist;
985
986 # Look at everything we think that mktables tells us exists, both loose and
987 # strict
988 foreach my $set_of_tables (\%utf8::stricter_to_file_of, \%utf8::loose_to_file_of)
989 {
990     foreach my $table (keys %$set_of_tables) {
991
992         my $mod_table;
993         my ($prop_only, $value) = split "=", $table;
994         if (defined $value) {
995
996             # If this is to be loose matched, add in characters to test that.
997             if ($set_of_tables == \%utf8::loose_to_file_of) {
998                 $value = "$extra_chars$value";
999             }
1000             else {  # Strict match
1001
1002                 # Verify that loose matching fails when only strict is called
1003                 # for.
1004                 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");
1005
1006                 # Strict matching does allow for underscores between digits.
1007                 # Test for that.
1008                 while ($value =~ s/(\d)(\d)/$1_$2/g) {}
1009             }
1010
1011             # The property portion in compound form specifications always
1012             # matches loosely
1013             $mod_table = "$extra_chars$prop_only = $value";
1014         }
1015         else {  # Single-form.
1016
1017             # Like above, use looose if required, and insert underscores
1018             # between digits if strict.
1019             if ($set_of_tables == \%utf8::loose_to_file_of) {
1020                 $mod_table = "$extra_chars$table";
1021             }
1022             else {
1023                 $mod_table = $table;
1024                 while ($mod_table =~ s/(\d)(\d)/$1_$2/g) {}
1025             }
1026         }
1027
1028         my @tested = prop_invlist($mod_table);
1029         if ($table =~ /^_/) {
1030             is(@tested, 0, "prop_invlist('$mod_table') returns an empty list since is internal-only");
1031             next;
1032         }
1033
1034         # If we have already tested a property that uses the same file, this
1035         # list should be identical to the one that was tested, and can bypass
1036         # everything else.
1037         my $file = $set_of_tables->{$table};
1038         if (exists $tested_invlist{$file}) {
1039             is_deeply(\@tested, $tested_invlist{$file}, "prop_invlist('$mod_table') gave same results as its name synonym");
1040             next;
1041         }
1042         $tested_invlist{$file} = dclone \@tested;
1043
1044         # A leading '!' in the file name means that it is to be inverted.
1045         my $invert = $file =~ s/^!//;
1046         my $official = do "unicore/lib/$file.pl";
1047
1048         # Get rid of any trailing space and comments in the file.
1049         $official =~ s/\s*(#.*)?$//mg;
1050         chomp $official;
1051
1052         # If we are to test against an inverted file, it is easier to invert
1053         # our array than the file.
1054         # The file only is valid for Unicode code points, while the inversion
1055         # list is valid for all possible code points.  Therefore, we must test
1056         # just the Unicode part against the file.  Later we will test for
1057         # the non-Unicode part.
1058
1059         my $before_invert;  # Saves the pre-inverted table.
1060         if ($invert) {
1061             $before_invert = dclone \@tested;
1062             if (@tested && $tested[0] == 0) {
1063                 shift @tested;
1064             } else {
1065                 unshift @tested, 0;
1066             }
1067             if (@tested && $tested[-1] == 0x110000) {
1068                 pop @tested;
1069             }
1070             else {
1071                 push @tested, 0x110000;
1072             }
1073         }
1074
1075         # Now construct a string from the list that should match the file.
1076         # The file gives ranges of code points with starting and ending values
1077         # in hex, like this:
1078         # 0041\t005A
1079         # 0061\t007A
1080         # 00AA
1081         # Our list has even numbered elements start ranges that are in the
1082         # list, and odd ones that aren't in the list.  Therefore the odd
1083         # numbered ones are one beyond the end of the previous range, but
1084         # otherwise don't get reflected in the file.
1085         my $tested = "";
1086         my $i = 0;
1087         for (; $i < @tested - 1; $i += 2) {
1088             my $start = $tested[$i];
1089             my $end = $tested[$i+1] - 1;
1090             if ($start == $end) {
1091                 $tested .= sprintf("%04X\n", $start);
1092             }
1093             else {
1094                 $tested .= sprintf "%04X\t%04X\n", $start, $end;
1095             }
1096         }
1097
1098         # As mentioned earlier, the disk files only go up through Unicode,
1099         # whereas the prop_invlist() ones go as high as necessary.  The
1100         # comparison is only valid through max Unicode.
1101         if ($i == @tested - 1 && $tested[$i] <= 0x10FFFF) {
1102             $tested .= sprintf("%04X\t10FFFF\n", $tested[$i]);
1103         }
1104         chomp $tested;
1105         if ($tested ne $official) {
1106             fail_with_diff($mod_table, $official, $tested, "prop_invlist");
1107             next;
1108         }
1109
1110         # Here, it matched the table.  Now need to check for if it is correct
1111         # for beyond Unicode.  First, calculate if is the default table or
1112         # not.  This is the same algorithm as used internally in
1113         # prop_invlist(), so if it is wrong there, this test won't catch it.
1114         my $prop = lc $table;
1115         ($prop_only, $table) = split /\s*[:=]\s*/, $prop;
1116         if (defined $table) {
1117
1118             # May have optional prefixed 'is'
1119             $prop = &utf8::_loose_name($prop_only) =~ s/^is//r;
1120             $prop = $utf8::loose_property_name_of{$prop};
1121             $prop .= "=" . &utf8::_loose_name($table);
1122         }
1123         else {
1124             $prop = &utf8::_loose_name($prop);
1125         }
1126         my $is_default = exists $Unicode::UCD::loose_defaults{$prop};
1127
1128         @tested = @$before_invert if $invert;    # Use the original
1129         if (@tested % 2 == 0) {
1130
1131             # If there are an even number of elements, the final one starts a
1132             # range (going to infinity) of code points that are not in the
1133             # list.
1134             if ($is_default) {
1135                 fail("prop_invlist('$mod_table')");
1136                 diag("default table doesn't goto infinity");
1137                 use Data::Dumper;
1138                 diag Dumper \@tested;
1139                 next;
1140             }
1141         }
1142         else {
1143             # An odd number of elements means the final one starts a range
1144             # (going to infinity of code points that are in the list.
1145             if (! $is_default) {
1146                 fail("prop_invlist('$mod_table')");
1147                 diag("non-default table needs to stop in the Unicode range");
1148                 use Data::Dumper;
1149                 diag Dumper \@tested;
1150                 next;
1151             }
1152         }
1153
1154         pass("prop_invlist('$mod_table')");
1155     }
1156 }
1157
1158 # Now test prop_invmap().
1159
1160 @list = prop_invmap("Unknown property");
1161 is (@list, 0, "prop_invmap(<Unknown property>) returns an empty list");
1162 @list = prop_invmap(undef);
1163 is (@list, 0, "prop_invmap(undef) returns an empty list");
1164 ok (! eval "prop_invmap('gc')" && $@ ne "",
1165                                 "prop_invmap('gc') dies in scalar context");
1166 @list = prop_invmap("_X_Begin");
1167 is (@list, 0, "prop_invmap(<internal property>) returns an empty list");
1168 @list = prop_invmap("InKana");
1169 is(@list, 0, "prop_invmap(<user-defined property returns undef>)");
1170 @list = prop_invmap("Perl_Decomposition_Mapping"), undef,
1171 is(@list, 0, "prop_invmap('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
1172 @list = prop_invmap("Perl_Charnames"), undef,
1173 is(@list, 0, "prop_invmap('Perl_Charnames') returns <undef> since internal-Perl-only");
1174 @list = prop_invmap("Is_Is_Any");
1175 is(@list, 0, "prop_invmap('Is_Is_Any') returns <undef> since two is's");
1176
1177 # The set of properties to test on has already been compiled into %props by
1178 # the prop_aliases() tests.
1179
1180 my %tested_invmaps;
1181
1182 # Like prop_invlist(), prop_invmap() is tested by comparing the results
1183 # returned by the function with the tables that mktables generates.  Some of
1184 # these tables are directly stored as files on disk, in either the unicore or
1185 # unicore/To directories, and most should be listed in the mktables generated
1186 # hash %utf8::loose_property_to_file_of, with a few additional ones that this
1187 # handles specially.  For these, the files are read in directly, massaged, and
1188 # compared with what invmap() returns.  The SPECIALS hash in some of these
1189 # files overrides values in the main part of the file.
1190 #
1191 # The other properties are tested indirectly by generating all the possible
1192 # inversion lists for the property, and seeing if those match the inversion
1193 # lists returned by prop_invlist(), which has already been tested.
1194
1195 PROPERTY:
1196 foreach my $prop (keys %props) {
1197     my $loose_prop = &utf8::_loose_name(lc $prop);
1198     my $suppressed = grep { $_ eq $loose_prop }
1199                           @Unicode::UCD::suppressed_properties;
1200
1201     # Find the short and full names that this property goes by
1202     my ($name, $full_name) = prop_aliases($prop);
1203     if (! $name) {
1204         if (! $suppressed) {
1205             fail("prop_invmap('$prop')");
1206             diag("is unknown to prop_aliases(), and we need it in order to test prop_invmap");
1207         }
1208         next PROPERTY;
1209     }
1210
1211     # Normalize the short name, as it is stored in the hashes under the
1212     # normalized version.
1213     $name = &utf8::_loose_name(lc $name);
1214
1215     # Add in the characters that are supposed to be ignored to test loose
1216     # matching, which the tested function applies to all properties
1217     my $mod_prop = "$extra_chars$prop";
1218
1219     my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($mod_prop);
1220     my $return_ref = [ $invlist_ref, $invmap_ref, $format, $missing ];
1221
1222     # If have already tested this property under a different name, merely
1223     # compare the return from now with the saved one from before.
1224     if (exists $tested_invmaps{$name}) {
1225         is_deeply($return_ref, $tested_invmaps{$name}, "prop_invmap('$mod_prop') gave same results as its synonym, '$name'");
1226         next PROPERTY;
1227     }
1228     $tested_invmaps{$name} = dclone $return_ref;
1229
1230     # If prop_invmap() returned nothing, is ok iff is a property whose file is
1231     # not generated.
1232     if ($suppressed) {
1233         if (defined $format) {
1234             fail("prop_invmap('$mod_prop')");
1235             diag("did not return undef for suppressed property $prop");
1236         }
1237         next PROPERTY;
1238     }
1239     elsif (!defined $format) {
1240         fail("prop_invmap('$mod_prop')");
1241         diag("'$prop' is unknown to prop_invmap()");
1242         next PROPERTY;
1243     }
1244
1245     # The two parallel arrays must have the same number of elements.
1246     if (@$invlist_ref != @$invmap_ref) {
1247         fail("prop_invmap('$mod_prop')");
1248         diag("invlist has "
1249              . scalar @$invlist_ref
1250              . " while invmap has "
1251              . scalar @$invmap_ref
1252              . " elements");
1253         next PROPERTY;
1254     }
1255
1256     # The last element must be for the above-Unicode code points, and must be
1257     # for the default value.
1258     if ($invlist_ref->[-1] != 0x110000) {
1259         fail("prop_invmap('$mod_prop')");
1260         diag("The last inversion list element is not 0x110000");
1261         next PROPERTY;
1262     }
1263     if ($invmap_ref->[-1] ne $missing) {
1264         fail("prop_invmap('$mod_prop')");
1265         diag("The last inversion list element is '$invmap_ref->[-1]', and should be '$missing'");
1266         next PROPERTY;
1267     }
1268
1269     if ($name eq 'bmg') {   # This one has an atypical $missing
1270         if ($missing ne "") {
1271             fail("prop_invmap('$mod_prop')");
1272             diag("The missings should be \"\"; got '$missing'");
1273             next PROPERTY;
1274         }
1275     }
1276     elsif ($format =~ /^ a (?!r) /x) {
1277         if ($full_name eq 'Perl_Decimal_Digit') {
1278             if ($missing ne "") {
1279                 fail("prop_invmap('$mod_prop')");
1280                 diag("The missings should be \"\"; got '$missing'");
1281                 next PROPERTY;
1282             }
1283         }
1284         elsif ($missing ne "0") {
1285             fail("prop_invmap('$mod_prop')");
1286             diag("The missings should be '0'; got '$missing'");
1287             next PROPERTY;
1288         }
1289     }
1290     elsif ($missing =~ /[<>]/) {
1291         fail("prop_invmap('$mod_prop')");
1292         diag("The missings should NOT be something with <...>'");
1293         next PROPERTY;
1294
1295         # I don't want to hard code in what all the missings should be, so
1296         # those don't get fully tested.
1297     }
1298
1299     # Certain properties don't have their own files, but must be constructed
1300     # using proxies.
1301     my $proxy_prop = $name;
1302     if ($full_name eq 'Present_In') {
1303         $proxy_prop = "age";    # The maps for these two props are identical
1304     }
1305     elsif ($full_name eq 'Simple_Case_Folding'
1306            || $full_name =~ /Simple_ (.) .*? case_Mapping  /x)
1307     {
1308         if ($full_name eq 'Simple_Case_Folding') {
1309             $proxy_prop = 'cf';
1310         }
1311         else {
1312             # We captured the U, L, or T, leading to uc, lc, or tc.
1313             $proxy_prop = lc $1 . "c";
1314         }
1315         if ($format ne "a") {
1316             fail("prop_invmap('$mod_prop')");
1317             diag("The format should be 'a'; got '$format'");
1318             next PROPERTY;
1319         }
1320     }
1321
1322     if ($format !~ / ^ (?: a [der]? | ale? | n | sl? ) $ /x) {
1323         fail("prop_invmap('$mod_prop')");
1324         diag("Unknown format '$format'");
1325         next PROPERTY;
1326     }
1327
1328     my $base_file;
1329     my $official;
1330
1331     # Handle the properties that have full disk files for them (except the
1332     # Name property which is structurally enough different that it is handled
1333     # separately below.)
1334     if ($name ne 'na'
1335         && ($name eq 'blk'
1336             || defined
1337                     ($base_file = $utf8::loose_property_to_file_of{$proxy_prop})
1338             || exists $utf8::loose_to_file_of{$proxy_prop}
1339             || $name eq "dm"))
1340     {
1341         # In the above, blk is done unconditionally, as we need to test that
1342         # the old-style block names are returned, even if mktables has
1343         # generated a file for the new-style; the test for dm comes afterward,
1344         # so that if a file has been generated for it explicitly, we use that
1345         # file (which is valid, unlike blk) instead of the combo
1346         # Decomposition.pl files.
1347         my $file;
1348         my $is_binary = 0;
1349         if ($name eq 'blk') {
1350
1351             # The blk property is special.  The original file with old block
1352             # names is retained, and the default is to not write out a
1353             # new-name file.  What we do is get the old names into a data
1354             # structure, and from that create what the new file would look
1355             # like.  $base_file is needed to be defined, just to avoid a
1356             # message below.
1357             $base_file = "This is a dummy name";
1358             my $blocks_ref = charblocks();
1359             $official = "";
1360             for my $range (sort { $a->[0][0] <=> $b->[0][0] }
1361                            values %$blocks_ref)
1362             {
1363                 # Translate the charblocks() data structure to what the file
1364                 # would like.
1365                 $official .= sprintf"%04X\t%04X\t%s\n",
1366                              $range->[0][0],
1367                              $range->[0][1],
1368                              $range->[0][2];
1369             }
1370         }
1371         else {
1372             $base_file = "Decomposition" if $format eq 'ad';
1373
1374             # Above leaves $base_file undefined only if it came from the hash
1375             # below.  This should happen only when it is a binary property
1376             # (and are accessing via a single-form name, like 'In_Latin1'),
1377             # and so it is stored in a different directory than the To ones.
1378             # XXX Currently, the only cases where it is complemented are the
1379             # ones that have no code points.  And it works out for these that
1380             # 1) complementing them, and then 2) adding or subtracting the
1381             # initial 0 and final 110000 cancel each other out.  But further
1382             # work would be needed in the unlikely event that an inverted
1383             # property comes along without these characteristics
1384             if (!defined $base_file) {
1385                 $base_file = $utf8::loose_to_file_of{$proxy_prop};
1386                 $is_binary = ($base_file =~ s/^!//) ? -1 : 1;
1387                 $base_file = "lib/$base_file";
1388             }
1389
1390             # Read in the file
1391             $file = "unicore/$base_file.pl";
1392             $official = do $file;
1393
1394             # Get rid of any trailing space and comments in the file.
1395             $official =~ s/\s*(#.*)?$//mg;
1396
1397             if ($format eq 'ad') {
1398                 my @official = split /\n/, $official;
1399                 $official = "";
1400                 foreach my $line (@official) {
1401                     my ($start, $end, $value)
1402                                     = $line =~ / ^ (.+?) \t (.*?) \t (.+?)
1403                                                 \s* ( \# .* )? $ /x;
1404                     # Decomposition.pl also has the <compatible> types in it,
1405                     # which should be removed.
1406                     $value =~ s/<.*?> //;
1407                     $official .= "$start\t\t$value\n";
1408
1409                     # If this is a multi-char range, we turn it into as many
1410                     # single character ranges as necessary.  This makes things
1411                     # easier below.
1412                     if ($end ne "") {
1413                         for my $i (hex($start) + 1 .. hex $end) {
1414                             $official .= sprintf "%04X\t\t%s\n", $i, $value;
1415                         }
1416                     }
1417                 }
1418             }
1419         }
1420         chomp $official;
1421
1422         # Get the format for the file, and if there are any special elements,
1423         # get a reference to them.
1424         my $swash_name = $utf8::file_to_swash_name{$base_file};
1425         my $specials_ref;
1426         my $file_format;
1427         if ($swash_name) {
1428             $specials_ref = $utf8::SwashInfo{$swash_name}{'specials_name'};
1429             if ($specials_ref) {
1430
1431                 # Convert from the name to the actual reference.
1432                 no strict 'refs';
1433                 $specials_ref = \%{$specials_ref};
1434             }
1435
1436             $file_format = $utf8::SwashInfo{$swash_name}{'format'};
1437         }
1438
1439         # Certain of the proxy properties have to be adjusted to match the
1440         # real ones.
1441         if ($full_name =~ /^(Case_Folding|(Lower|Title|Upper)case_Mapping)/) {
1442
1443             # Here we have either
1444             #   1) Case_Folding; or
1445             #   2) a proxy that is a full mapping, which means that what the
1446             #      real property is is the equivalent simple mapping.
1447             # In both cases, the file will have a standard list containing
1448             # simple mappings (to a single code point), and a specials hash
1449             # which contains all the mappings that are to multiple code
1450             # points.  First, extract a list containing all the file's simple
1451             # mappings.
1452             my @list;
1453             for (split "\n", $official) {
1454                 my ($start, $end, $value) = / ^ (.+?) \t (.*?) \t (.+?)
1455                                                 \s* ( \# .* )? $ /x;
1456                 $end = $start if $end eq "";
1457                 push @list, [ hex $start, hex $end, $value ];
1458             }
1459
1460             # For these mappings, the file contains all the simple mappings,
1461             # including the ones that are overridden by the specials.  These
1462             # need to be removed as the list is for just the full ones.
1463
1464             # Go through any special mappings one by one.  They are packed.
1465             my $i = 0;
1466             foreach my $utf8_cp (sort keys %$specials_ref) {
1467                 my $cp = unpack("C0U", $utf8_cp);
1468
1469                 # Find the spot in the @list of simple mappings that this
1470                 # special applies to; uses a linear search.
1471                 while ($i < @list -1 ) {
1472                     last if  $cp <= $list[$i][1];
1473                     $i++;
1474                 }
1475
1476                 # Here $i is such that it points to the first range which ends
1477                 # at or above cp, and hence is the only range that could
1478                 # possibly contain it.
1479
1480                 # If not in this range, no range contains it: nothing to
1481                 # remove.
1482                 next if $cp < $list[$i][0];
1483
1484                 # Otherwise, remove the existing entry.  If it is the first
1485                 # element of the range...
1486                 if ($cp == $list[$i][0]) {
1487
1488                     # ... and there are other elements in the range, just shorten
1489                     # the range to exclude this code point.
1490                     if ($list[$i][1] > $list[$i][0]) {
1491                         $list[$i][0]++;
1492                     }
1493
1494                     # ... but if it is the only element in the range, remove
1495                     # it entirely.
1496                     else {
1497                         splice @list, $i, 1;
1498                     }
1499                 }
1500                 else { # Is somewhere in the middle of the range
1501                     # Split the range into two, excluding this one in the
1502                     # middle
1503                     splice @list, $i, 1,
1504                            [ $list[$i][0], $cp - 1, $list[$i][2] ],
1505                            [ $cp + 1, $list[$i][1], $list[$i][2] ];
1506                 }
1507             }
1508
1509             # Here, have gone through all the specials, modifying @list as
1510             # needed.  Turn it back into what the file should look like.
1511             $official = "";
1512             for my $element (@list) {
1513                 $official .= "\n" if $official;
1514                 if ($element->[1] == $element->[0]) {
1515                     $official .= sprintf "%04X\t\t%s", $element->[0], $element->[2];
1516                 }
1517                 else {
1518                     $official .= sprintf "%04X\t%04X\t%s", $element->[0], $element->[1], $element->[2];
1519                 }
1520             }
1521         }
1522         elsif ($full_name =~ /Simple_(Case_Folding|(Lower|Title|Upper)case_Mapping)/)
1523         {
1524
1525             # These properties have everything in the regular array, and the
1526             # specials are superfluous.
1527             undef $specials_ref;
1528         }
1529         elsif ($format !~ /^a/ && defined $file_format && $file_format eq 'x') {
1530
1531             # For these properties the file is output using hex notation for the
1532             # map.  Convert from hex to decimal.
1533             my @lines = split "\n", $official;
1534             foreach my $line (@lines) {
1535                 my ($lower, $upper, $map) = split "\t", $line;
1536                 $line = "$lower\t$upper\t" . hex $map;
1537             }
1538             $official = join "\n", @lines;
1539         }
1540
1541         # Here, in $official, we have what the file looks like, or should like
1542         # if we've had to fix it up.  Now take the invmap() output and reverse
1543         # engineer from that what the file should look like.  Each iteration
1544         # appends the next line to the running string.
1545         my $tested_map = "";
1546
1547         # Create a copy of the file's specials hash.  (It has been undef'd if
1548         # we know it isn't relevant to this property, so if it exists, it's an
1549         # error or is relevant).  As we go along, we delete from that copy.
1550         # If a delete fails, or something is left over after we are done,
1551         # it's an error
1552         my %specials = %$specials_ref if $specials_ref;
1553
1554         # The extra -1 is because the final element has been tested above to
1555         # be for anything above Unicode.  The file doesn't go that high.
1556         for (my $i = 0; $i <  @$invlist_ref - 1; $i++) {
1557
1558             # If the map element is a reference, have to stringify it (but
1559             # don't do so if the format doesn't allow references, so that an
1560             # improper format will generate an error.
1561             if (ref $invmap_ref->[$i]
1562                 && ($format eq 'ad' || $format =~ /^ . l /x))
1563             {
1564                 # The stringification depends on the format.
1565                 if ($format eq 'sl') {
1566
1567                     # At the time of this writing, there are two types of 'sl'
1568                     # format  One, in Name_Alias, has multiple separate entries
1569                     # for each code point; the other, in Script_Extension, is space
1570                     # separated.  Assume the latter for non-Name_Alias.
1571                     if ($full_name ne 'Name_Alias') {
1572                         $invmap_ref->[$i] = join " ", @{$invmap_ref->[$i]};
1573                     }
1574                     else {
1575                         # For Name_Alias, we emulate the file.  Entries with
1576                         # just one value don't need any changes, but we
1577                         # convert the list entries into a series of lines for
1578                         # the file, starting with the first name.  The
1579                         # succeeding entries are on separate lines, with the
1580                         # code point repeated for each one and then two tabs,
1581                         # then the value.  Code at the end of the loop will
1582                         # set up the first line with its code point and two
1583                         # tabs before the value, just as it does for every
1584                         # other property; thus the special handling of the
1585                         # first line.
1586                         if (ref $invmap_ref->[$i]) {
1587                             my $hex_cp = sprintf("%04X", $invlist_ref->[$i]);
1588                             my $concatenated = $invmap_ref->[$i][0];
1589                             for (my $j = 1; $j < @{$invmap_ref->[$i]}; $j++) {
1590                                 $concatenated .= "\n$hex_cp\t\t" . $invmap_ref->[$i][$j];
1591                             }
1592                             $invmap_ref->[$i] = $concatenated;
1593                         }
1594                     }
1595                 }
1596                 elsif ($format =~ / ^ al e? $/x) {
1597
1598                     # For a al property, the stringified result should be in
1599                     # the specials hash.  The key is the packed code point,
1600                     # and the value is the packed map.
1601                     my $value;
1602                     if (! defined ($value = delete $specials{pack("C0U", $invlist_ref->[$i]) })) {
1603                         fail("prop_invmap('$mod_prop')");
1604                         diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]);
1605                         next PROPERTY;
1606                     }
1607                     my $packed = pack "U*", @{$invmap_ref->[$i]};
1608                     if ($value ne $packed) {
1609                         fail("prop_invmap('$mod_prop')");
1610                         diag(sprintf "For %04X, expected the mapping to be '$packed', but got '$value'");
1611                         next PROPERTY;
1612                     }
1613
1614                     # As this doesn't get tested when we later compare with
1615                     # the actual file, it could be out of order and we
1616                     # wouldn't know it.
1617                     if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1618                         || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1619                     {
1620                         fail("prop_invmap('$mod_prop')");
1621                         diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1622                         next PROPERTY;
1623                     }
1624                     next;
1625                 }
1626                 elsif ($format eq 'ad') {
1627
1628                     # The decomposition mapping file has the code points as
1629                     # a string of space-separated hex constants.
1630                     $invmap_ref->[$i] = join " ", map { sprintf "%04X", $_ } @{$invmap_ref->[$i]};
1631                 }
1632                 else {
1633                     fail("prop_invmap('$mod_prop')");
1634                     diag("Can't handle format '$format'");
1635                     next PROPERTY;
1636                 }
1637             }
1638             elsif ($format eq 'ad' || $format eq 'ale') {
1639
1640                 # The numerics in the returned map are stored as adjusted
1641                 # decimal integers.  The defaults are 0, and don't appear in
1642                 # $official, and are excluded later, but the elements must be
1643                 # converted back to their hex values before comparing with
1644                 # $official, as these files, for backwards compatibility, are
1645                 # not stored as adjusted.  (There currently is only one ale
1646                 # property, nfkccf.  If that changed this would also have to.)
1647                 if ($invmap_ref->[$i] =~ / ^ -? \d+ $ /x
1648                     && $invmap_ref->[$i] != 0)
1649                 {
1650                     my $next = $invmap_ref->[$i] + 1;
1651                     $invmap_ref->[$i] = sprintf("%04X", $invmap_ref->[$i]);
1652
1653                     # If there are other elements in this range they need to
1654                     # be adjusted; they must individually be re-mapped.  Do
1655                     # this by splicing in a new element into the list and the
1656                     # map containing the remainder of the range.  Next time
1657                     # through we will look at that (possibly splicing again
1658                     # until the whole range is processed).
1659                     if ($invlist_ref->[$i+1] > $invlist_ref->[$i] + 1) {
1660                         splice @$invlist_ref, $i+1, 0,
1661                                 $invlist_ref->[$i] + 1;
1662                         splice @$invmap_ref, $i+1, 0, $next;
1663                     }
1664                 }
1665                 if ($format eq 'ale' && $invmap_ref->[$i] eq "") {
1666
1667                     # ale properties have maps to the empty string that also
1668                     # should be in the specials hash, with the key the packed
1669                     # code point, and the map just empty.
1670                     my $value;
1671                     if (! defined ($value = delete $specials{pack("C0U", $invlist_ref->[$i]) })) {
1672                         fail("prop_invmap('$mod_prop')");
1673                         diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]);
1674                         next PROPERTY;
1675                     }
1676                     if ($value ne "") {
1677                         fail("prop_invmap('$mod_prop')");
1678                         diag(sprintf "For %04X, expected the mapping to be \"\", but got '$value'", $invlist_ref->[$i]);
1679                         next PROPERTY;
1680                     }
1681
1682                     # As this doesn't get tested when we later compare with
1683                     # the actual file, it could be out of order and we
1684                     # wouldn't know it.
1685                     if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1686                         || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1687                     {
1688                         fail("prop_invmap('$mod_prop')");
1689                         diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1690                         next PROPERTY;
1691                     }
1692                     next;
1693                 }
1694             }
1695             elsif ($is_binary) { # These binary files don't have an explicit Y
1696                 $invmap_ref->[$i] =~ s/Y//;
1697             }
1698
1699             # The file doesn't include entries that map to $missing, so don't
1700             # include it in the built-up string.  But make sure that it is in
1701             # the correct order in the input.
1702             if ($invmap_ref->[$i] eq $missing) {
1703                 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1704                     || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1705                 {
1706                     fail("prop_invmap('$mod_prop')");
1707                     diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1708                     next PROPERTY;
1709                 }
1710                 next;
1711             }
1712
1713             # The ad property has one entry which isn't in the file.
1714             # Ignore it, but make sure it is in order.
1715             if ($format eq 'ad'
1716                 && $invmap_ref->[$i] eq '<hangul syllable>'
1717                 && $invlist_ref->[$i] == 0xAC00)
1718             {
1719                 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1720                     || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1721                 {
1722                     fail("prop_invmap('$mod_prop')");
1723                     diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1724                     next PROPERTY;
1725                 }
1726                 next;
1727             }
1728
1729             # Finally have figured out what the map column in the file should
1730             # be.  Append the line to the running string.
1731             my $start = $invlist_ref->[$i];
1732             my $end = $invlist_ref->[$i+1] - 1;
1733             $end = ($start == $end) ? "" : sprintf("%04X", $end);
1734             if ($invmap_ref->[$i] ne "") {
1735                 $tested_map .= sprintf "%04X\t%s\t%s\n", $start, $end, $invmap_ref->[$i];
1736             }
1737             elsif ($end ne "") {
1738                 $tested_map .= sprintf "%04X\t%s\n", $start, $end;
1739             }
1740             else {
1741                 $tested_map .= sprintf "%04X\n", $start;
1742             }
1743         } # End of looping over all elements.
1744
1745         # Here are done with generating what the file should look like
1746
1747         chomp $tested_map;
1748
1749         # And compare.
1750         if ($tested_map ne $official) {
1751             fail_with_diff($mod_prop, $official, $tested_map, "prop_invmap");
1752             next PROPERTY;
1753         }
1754
1755         # There shouldn't be any specials unaccounted for.
1756         if (keys %specials) {
1757             fail("prop_invmap('$mod_prop')");
1758             diag("Unexpected specials: " . join ", ", keys %specials);
1759             next PROPERTY;
1760         }
1761     }
1762     elsif ($format eq 'n') {
1763
1764         # Handle the Name property similar to the above.  But the file is
1765         # sufficiently different that it is more convenient to make a special
1766         # case for it.  It is a combination of the Name, Unicode1_Name, and
1767         # Name_Alias properties, and named sequences.  We need to remove all
1768         # but the Name in order to do the comparison.
1769
1770         if ($missing ne "") {
1771             fail("prop_invmap('$mod_prop')");
1772             diag("The missings should be \"\"; got \"missing\"");
1773             next PROPERTY;
1774         }
1775
1776         $official = do "unicore/Name.pl";
1777
1778         # Get rid of the named sequences portion of the file.  These don't
1779         # have a tab before the first blank on a line.
1780         $official =~ s/ ^ [^\t]+ \  .*? \n //xmg;
1781
1782         # And get rid of the controls.  These are named in the file, but
1783         # shouldn't be in the property.  This gets rid of the two ranges in
1784         # one fell swoop, and also all the Unicode1_Name values that may not
1785         # be in Name_Alias.
1786         $official =~ s/ 00000 \t .* 0001F .*? \n//xs;
1787         $official =~ s/ 0007F \t .* 0009F .*? \n//xs;
1788
1789         # And remove the aliases.  We read in the Name_Alias property, and go
1790         # through them one by one.
1791         my ($aliases_code_points, $aliases_maps, undef, undef)
1792                                                 = &prop_invmap('Name_Alias');
1793         for (my $i = 0; $i < @$aliases_code_points; $i++) {
1794             my $code_point = $aliases_code_points->[$i];
1795
1796             # Already removed these above.
1797             next if $code_point <= 0x1F
1798                     || ($code_point >= 0x7F && $code_point <= 0x9F);
1799
1800             my $hex_code_point = sprintf "%05X", $code_point;
1801
1802             # Convert to a list if not already to make the following loop
1803             # control uniform.
1804             $aliases_maps->[$i] = [ $aliases_maps->[$i] ]
1805                                                 if ! ref $aliases_maps->[$i];
1806
1807             # Remove each alias for this code point from the file
1808             foreach my $alias (@{$aliases_maps->[$i]}) {
1809
1810                 # Remove the alias type from the entry, retaining just the name.
1811                 $alias =~ s/:.*//;
1812
1813                 $alias = quotemeta($alias);
1814                 $official =~ s/$hex_code_point \t $alias \n //x;
1815             }
1816         }
1817         chomp $official;
1818
1819         # Here have adjusted the file.  We also have to adjust the returned
1820         # inversion map by checking and deleting all the lines in it that
1821         # won't be in the file.  These are the lines that have generated
1822         # things, like <hangul syllable>.
1823         my $tested_map = "";        # Current running string
1824         my @code_point_in_names =
1825                                @Unicode::UCD::code_points_ending_in_code_point;
1826
1827         for my $i (0 .. @$invlist_ref - 1 - 1) {
1828             my $start = $invlist_ref->[$i];
1829             my $end = $invlist_ref->[$i+1] - 1;
1830             if ($invmap_ref->[$i] eq $missing) {
1831                 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1832                     || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1833                 {
1834                     fail("prop_invmap('$mod_prop')");
1835                     diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1836                     next PROPERTY;
1837                 }
1838                 next;
1839             }
1840             if ($invmap_ref->[$i] =~ / (.*) ( < .*? > )/x) {
1841                 my $name = $1;
1842                 my $type = $2;
1843                 if (($i > 0 && $invlist_ref->[$i] <= $invlist_ref->[$i-1])
1844                     || $invlist_ref->[$i] >= $invlist_ref->[$i+1])
1845                 {
1846                     fail("prop_invmap('$mod_prop')");
1847                     diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1848                     next PROPERTY;
1849                 }
1850                 if ($type eq "<hangul syllable>") {
1851                     if ($name ne "") {
1852                         fail("prop_invmap('$mod_prop')");
1853                         diag("Unexpected text in $invmap_ref->[$i]");
1854                         next PROPERTY;
1855                     }
1856                     if ($start != 0xAC00) {
1857                         fail("prop_invmap('$mod_prop')");
1858                         diag(sprintf("<hangul syllables> should begin at 0xAC00, got %04X", $start));
1859                         next PROPERTY;
1860                     }
1861                     if ($end != $start + 11172 - 1) {
1862                         fail("prop_invmap('$mod_prop')");
1863                         diag(sprintf("<hangul syllables> should end at %04X, got %04X", $start + 11172 -1, $end));
1864                         next PROPERTY;
1865                     }
1866                 }
1867                 elsif ($type ne "<code point>") {
1868                     fail("prop_invmap('$mod_prop')");
1869                     diag("Unexpected text '$type' in $invmap_ref->[$i]");
1870                     next PROPERTY;
1871                 }
1872                 else {
1873
1874                     # Look through the array of names that end in code points,
1875                     # and look for this start and end.  If not found is an
1876                     # error.  If found, delete it, and at the end, make sure
1877                     # have deleted everything.
1878                     for my $i (0 .. @code_point_in_names - 1) {
1879                         my $hash = $code_point_in_names[$i];
1880                         if ($hash->{'low'} == $start
1881                             && $hash->{'high'} == $end
1882                             && "$hash->{'name'}-" eq $name)
1883                         {
1884                             splice @code_point_in_names, $i, 1;
1885                             last;
1886                         }
1887                         else {
1888                             fail("prop_invmap('$mod_prop')");
1889                             diag("Unexpected code-point-in-name line '$invmap_ref->[$i]'");
1890                             next PROPERTY;
1891                         }
1892                     }
1893                 }
1894
1895                 next;
1896             }
1897
1898             # Have adjusted the map, as needed.  Append to running string.
1899             $end = ($start == $end) ? "" : sprintf("%05X", $end);
1900             $tested_map .= sprintf "%05X\t%s\n", $start, $invmap_ref->[$i];
1901         }
1902
1903         # Finished creating the string from the inversion map.  Can compare
1904         # with what the file is.
1905         chomp $tested_map;
1906         if ($tested_map ne $official) {
1907             fail_with_diff($mod_prop, $official, $tested_map, "prop_invmap");
1908             next PROPERTY;
1909         }
1910         if (@code_point_in_names) {
1911             fail("prop_invmap('$mod_prop')");
1912             use Data::Dumper;
1913             diag("Missing code-point-in-name line(s)" . Dumper \@code_point_in_names);
1914             next PROPERTY;
1915         }
1916     }
1917     elsif ($format eq 's') {
1918
1919         # Here the map is not more or less directly from a file stored on
1920         # disk.  We try a different tack.  These should all be properties that
1921         # have just a few possible values (most of them are  binary).  We go
1922         # through the map list, sorting each range into buckets, one for each
1923         # map value.  Thus for binary properties there will be a bucket for Y
1924         # and one for N.  The buckets are inversion lists.  We compare each
1925         # constructed inversion list with what we would get for it using
1926         # prop_invlist(), which has already been tested.  If they all match,
1927         # the whole map must have matched.
1928         my %maps;
1929         my $previous_map;
1930
1931         # (The extra -1 is to not look at the final element in the loop, which
1932         # we know is the one that starts just beyond Unicode and goes to
1933         # infinity.)
1934         for my $i (0 .. @$invlist_ref - 1 - 1) {
1935             my $range_start = $invlist_ref->[$i];
1936
1937             # Because we are sorting into buckets, things could be
1938             # out-of-order here, and still be in the correct order in the
1939             # bucket, and hence wouldn't show up as an error; so have to
1940             # check.
1941             if (($i > 0 && $range_start <= $invlist_ref->[$i-1])
1942                 || $range_start >= $invlist_ref->[$i+1])
1943             {
1944                 fail("prop_invmap('$mod_prop')");
1945                 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1946                 next PROPERTY;
1947             }
1948
1949             # This new range closes out the range started in the previous
1950             # iteration.
1951             push @{$maps{$previous_map}}, $range_start if defined $previous_map;
1952
1953             # And starts a range which will be closed in the next iteration.
1954             $previous_map = $invmap_ref->[$i];
1955             push @{$maps{$previous_map}}, $range_start;
1956         }
1957
1958         # The range we just started hasn't been closed, and we didn't look at
1959         # the final element of the loop.  If that range is for the default
1960         # value, it shouldn't be closed, as it is to extend to infinity.  But
1961         # otherwise, it should end at the final Unicode code point, and the
1962         # list that maps to the default value should have another element that
1963         # does go to infinity for every above Unicode code point.
1964
1965         if (@$invlist_ref > 1) {
1966             my $penultimate_map = $invmap_ref->[-2];
1967             if ($penultimate_map ne $missing) {
1968
1969                 # The -1th element contains the first non-Unicode code point.
1970                 push @{$maps{$penultimate_map}}, $invlist_ref->[-1];
1971                 push @{$maps{$missing}}, $invlist_ref->[-1];
1972             }
1973         }
1974
1975         # Here, we have the buckets (inversion lists) all constructed.  Go
1976         # through each and verify that matches what prop_invlist() returns.
1977         # We could use is_deeply() for the comparison, but would get multiple
1978         # messages for each $prop.
1979         foreach my $map (keys %maps) {
1980             my @off_invlist = prop_invlist("$prop = $map");
1981             my $min = (@off_invlist >= @{$maps{$map}})
1982                        ? @off_invlist
1983                        : @{$maps{$map}};
1984             for my $i (0 .. $min- 1) {
1985                 if ($i > @off_invlist - 1) {
1986                     fail("prop_invmap('$mod_prop')");
1987                     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]'");
1988                     next PROPERTY;
1989                 }
1990                 elsif ($i > @{$maps{$map}} - 1) {
1991                     fail("prop_invmap('$mod_prop')");
1992                     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]'");
1993                     next PROPERTY;
1994                 }
1995                 elsif ($maps{$map}[$i] ne $off_invlist[$i]) {
1996                     fail("prop_invmap('$mod_prop')");
1997                     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]'");
1998                     next PROPERTY;
1999                 }
2000             }
2001         }
2002     }
2003     else {  # Don't know this property nor format.
2004
2005         fail("prop_invmap('$mod_prop')");
2006         diag("Unknown format '$format'");
2007     }
2008
2009     pass("prop_invmap('$mod_prop')");
2010 }
2011
2012 done_testing();