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
CommitLineData
25a47338 1#!perl -w
8b731da2 2BEGIN {
a452d459 3 if (ord("A") != 65) {
8b731da2
JH
4 print "1..0 # Skip: EBCDIC\n";
5 exit 0;
6 }
a778afa6
AD
7 chdir 't' if -d 't';
8 @INC = '../lib';
25a47338
NC
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 }
8b731da2
JH
14}
15
a778afa6
AD
16use strict;
17use Unicode::UCD;
f5c9f3db 18use Test::More;
8b731da2 19
55d7b906 20use Unicode::UCD 'charinfo';
561c79ed 21
4f1530fd
KW
22$/ = 7;
23
b08cd201
JH
24my $charinfo;
25
9e92970c
KW
26is(charinfo(0x110000), undef, "Verify charinfo() of non-unicode is undef");
27
e10d7780
KW
28$charinfo = charinfo(0); # Null is often problematic, so test it.
29
30is($charinfo->{code}, '0000', '<control>');
31is($charinfo->{name}, '<control>');
32is($charinfo->{category}, 'Cc');
33is($charinfo->{combining}, '0');
34is($charinfo->{bidi}, 'BN');
35is($charinfo->{decomposition}, '');
36is($charinfo->{decimal}, '');
37is($charinfo->{digit}, '');
38is($charinfo->{numeric}, '');
39is($charinfo->{mirrored}, 'N');
40is($charinfo->{unicode10}, 'NULL');
41is($charinfo->{comment}, '');
42is($charinfo->{upper}, '');
43is($charinfo->{lower}, '');
44is($charinfo->{title}, '');
45is($charinfo->{block}, 'Basic Latin');
46is($charinfo->{script}, 'Common');
47
b08cd201
JH
48$charinfo = charinfo(0x41);
49
f5c9f3db
JH
50is($charinfo->{code}, '0041', 'LATIN CAPITAL LETTER A');
51is($charinfo->{name}, 'LATIN CAPITAL LETTER A');
52is($charinfo->{category}, 'Lu');
53is($charinfo->{combining}, '0');
54is($charinfo->{bidi}, 'L');
55is($charinfo->{decomposition}, '');
56is($charinfo->{decimal}, '');
57is($charinfo->{digit}, '');
58is($charinfo->{numeric}, '');
59is($charinfo->{mirrored}, 'N');
60is($charinfo->{unicode10}, '');
61is($charinfo->{comment}, '');
62is($charinfo->{upper}, '');
63is($charinfo->{lower}, '0061');
64is($charinfo->{title}, '');
65is($charinfo->{block}, 'Basic Latin');
66is($charinfo->{script}, 'Latin');
b08cd201
JH
67
68$charinfo = charinfo(0x100);
69
f5c9f3db
JH
70is($charinfo->{code}, '0100', 'LATIN CAPITAL LETTER A WITH MACRON');
71is($charinfo->{name}, 'LATIN CAPITAL LETTER A WITH MACRON');
72is($charinfo->{category}, 'Lu');
73is($charinfo->{combining}, '0');
74is($charinfo->{bidi}, 'L');
75is($charinfo->{decomposition}, '0041 0304');
76is($charinfo->{decimal}, '');
77is($charinfo->{digit}, '');
78is($charinfo->{numeric}, '');
79is($charinfo->{mirrored}, 'N');
80is($charinfo->{unicode10}, 'LATIN CAPITAL LETTER A MACRON');
81is($charinfo->{comment}, '');
82is($charinfo->{upper}, '');
83is($charinfo->{lower}, '0101');
84is($charinfo->{title}, '');
85is($charinfo->{block}, 'Latin Extended-A');
86is($charinfo->{script}, 'Latin');
a196fbfd
JH
87
88# 0x0590 is in the Hebrew block but unused.
561c79ed 89
b08cd201
JH
90$charinfo = charinfo(0x590);
91
f5c9f3db
JH
92is($charinfo->{code}, undef, '0x0590 - unused Hebrew');
93is($charinfo->{name}, undef);
94is($charinfo->{category}, undef);
95is($charinfo->{combining}, undef);
96is($charinfo->{bidi}, undef);
97is($charinfo->{decomposition}, undef);
98is($charinfo->{decimal}, undef);
99is($charinfo->{digit}, undef);
100is($charinfo->{numeric}, undef);
101is($charinfo->{mirrored}, undef);
102is($charinfo->{unicode10}, undef);
103is($charinfo->{comment}, undef);
104is($charinfo->{upper}, undef);
105is($charinfo->{lower}, undef);
106is($charinfo->{title}, undef);
107is($charinfo->{block}, undef);
108is($charinfo->{script}, undef);
a196fbfd
JH
109
110# 0x05d0 is in the Hebrew block and used.
561c79ed 111
b08cd201
JH
112$charinfo = charinfo(0x5d0);
113
f5c9f3db
JH
114is($charinfo->{code}, '05D0', '05D0 - used Hebrew');
115is($charinfo->{name}, 'HEBREW LETTER ALEF');
116is($charinfo->{category}, 'Lo');
117is($charinfo->{combining}, '0');
118is($charinfo->{bidi}, 'R');
119is($charinfo->{decomposition}, '');
120is($charinfo->{decimal}, '');
121is($charinfo->{digit}, '');
122is($charinfo->{numeric}, '');
123is($charinfo->{mirrored}, 'N');
124is($charinfo->{unicode10}, '');
125is($charinfo->{comment}, '');
126is($charinfo->{upper}, '');
127is($charinfo->{lower}, '');
128is($charinfo->{title}, '');
129is($charinfo->{block}, 'Hebrew');
130is($charinfo->{script}, 'Hebrew');
561c79ed 131
74f8133e 132# An open syllable in Hangul.
a6fa416b
ST
133
134$charinfo = charinfo(0xAC00);
135
05dbc6f8
KW
136is($charinfo->{code}, 'AC00', 'HANGUL SYLLABLE U+AC00');
137is($charinfo->{name}, 'HANGUL SYLLABLE GA');
f5c9f3db
JH
138is($charinfo->{category}, 'Lo');
139is($charinfo->{combining}, '0');
140is($charinfo->{bidi}, 'L');
05dbc6f8 141is($charinfo->{decomposition}, '1100 1161');
f5c9f3db
JH
142is($charinfo->{decimal}, '');
143is($charinfo->{digit}, '');
144is($charinfo->{numeric}, '');
145is($charinfo->{mirrored}, 'N');
146is($charinfo->{unicode10}, '');
147is($charinfo->{comment}, '');
148is($charinfo->{upper}, '');
149is($charinfo->{lower}, '');
150is($charinfo->{title}, '');
151is($charinfo->{block}, 'Hangul Syllables');
152is($charinfo->{script}, 'Hangul');
a6fa416b 153
74f8133e 154# A closed syllable in Hangul.
a6fa416b
ST
155
156$charinfo = charinfo(0xAE00);
157
05dbc6f8
KW
158is($charinfo->{code}, 'AE00', 'HANGUL SYLLABLE U+AE00');
159is($charinfo->{name}, 'HANGUL SYLLABLE GEUL');
f5c9f3db
JH
160is($charinfo->{category}, 'Lo');
161is($charinfo->{combining}, '0');
162is($charinfo->{bidi}, 'L');
05dbc6f8 163is($charinfo->{decomposition}, "1100 1173 11AF");
f5c9f3db
JH
164is($charinfo->{decimal}, '');
165is($charinfo->{digit}, '');
166is($charinfo->{numeric}, '');
167is($charinfo->{mirrored}, 'N');
168is($charinfo->{unicode10}, '');
169is($charinfo->{comment}, '');
170is($charinfo->{upper}, '');
171is($charinfo->{lower}, '');
172is($charinfo->{title}, '');
173is($charinfo->{block}, 'Hangul Syllables');
174is($charinfo->{script}, 'Hangul');
a6fa416b
ST
175
176$charinfo = charinfo(0x1D400);
177
f5c9f3db
JH
178is($charinfo->{code}, '1D400', 'MATHEMATICAL BOLD CAPITAL A');
179is($charinfo->{name}, 'MATHEMATICAL BOLD CAPITAL A');
180is($charinfo->{category}, 'Lu');
181is($charinfo->{combining}, '0');
182is($charinfo->{bidi}, 'L');
183is($charinfo->{decomposition}, '<font> 0041');
184is($charinfo->{decimal}, '');
185is($charinfo->{digit}, '');
186is($charinfo->{numeric}, '');
187is($charinfo->{mirrored}, 'N');
188is($charinfo->{unicode10}, '');
189is($charinfo->{comment}, '');
190is($charinfo->{upper}, '');
191is($charinfo->{lower}, '');
192is($charinfo->{title}, '');
193is($charinfo->{block}, 'Mathematical Alphanumeric Symbols');
7be0dac3 194is($charinfo->{script}, 'Common');
a6fa416b 195
a452d459
KW
196$charinfo = charinfo(0x9FBA); #Bug 58428
197
198is($charinfo->{code}, '9FBA', 'U+9FBA');
199is($charinfo->{name}, 'CJK UNIFIED IDEOGRAPH-9FBA');
200is($charinfo->{category}, 'Lo');
201is($charinfo->{combining}, '0');
202is($charinfo->{bidi}, 'L');
203is($charinfo->{decomposition}, '');
204is($charinfo->{decimal}, '');
205is($charinfo->{digit}, '');
206is($charinfo->{numeric}, '');
207is($charinfo->{mirrored}, 'N');
208is($charinfo->{unicode10}, '');
209is($charinfo->{comment}, '');
210is($charinfo->{upper}, '');
211is($charinfo->{lower}, '');
212is($charinfo->{title}, '');
213is($charinfo->{block}, 'CJK Unified Ideographs');
214is($charinfo->{script}, 'Han');
215
55d7b906 216use Unicode::UCD qw(charblock charscript);
a196fbfd
JH
217
218# 0x0590 is in the Hebrew block but unused.
561c79ed 219
f5c9f3db 220is(charblock(0x590), 'Hebrew', '0x0590 - Hebrew unused charblock');
8079ad82 221is(charscript(0x590), 'Unknown', '0x0590 - Hebrew unused charscript');
c707cf8e 222is(charblock(0x1FFFF), 'No_Block', '0x1FFFF - unused charblock');
561c79ed 223
b08cd201
JH
224$charinfo = charinfo(0xbe);
225
f5c9f3db
JH
226is($charinfo->{code}, '00BE', 'VULGAR FRACTION THREE QUARTERS');
227is($charinfo->{name}, 'VULGAR FRACTION THREE QUARTERS');
228is($charinfo->{category}, 'No');
229is($charinfo->{combining}, '0');
230is($charinfo->{bidi}, 'ON');
231is($charinfo->{decomposition}, '<fraction> 0033 2044 0034');
232is($charinfo->{decimal}, '');
233is($charinfo->{digit}, '');
234is($charinfo->{numeric}, '3/4');
235is($charinfo->{mirrored}, 'N');
236is($charinfo->{unicode10}, 'FRACTION THREE QUARTERS');
237is($charinfo->{comment}, '');
238is($charinfo->{upper}, '');
239is($charinfo->{lower}, '');
240is($charinfo->{title}, '');
241is($charinfo->{block}, 'Latin-1 Supplement');
7be0dac3 242is($charinfo->{script}, 'Common');
10a6ecd2 243
7fcb6f68
KW
244# This is to test a case where both simple and full lowercases exist and
245# differ
246$charinfo = charinfo(0x130);
247
248is($charinfo->{code}, '0130', 'LATIN CAPITAL LETTER I WITH DOT ABOVE');
249is($charinfo->{name}, 'LATIN CAPITAL LETTER I WITH DOT ABOVE');
250is($charinfo->{category}, 'Lu');
251is($charinfo->{combining}, '0');
252is($charinfo->{bidi}, 'L');
253is($charinfo->{decomposition}, '0049 0307');
254is($charinfo->{decimal}, '');
255is($charinfo->{digit}, '');
256is($charinfo->{numeric}, '');
257is($charinfo->{mirrored}, 'N');
258is($charinfo->{unicode10}, 'LATIN CAPITAL LETTER I DOT');
259is($charinfo->{comment}, '');
260is($charinfo->{upper}, '');
261is($charinfo->{lower}, '0069');
262is($charinfo->{title}, '');
263is($charinfo->{block}, 'Latin Extended-A');
264is($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
270is($charinfo->{code}, '1F80', 'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
271is($charinfo->{name}, 'GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI');
272is($charinfo->{category}, 'Ll');
273is($charinfo->{combining}, '0');
274is($charinfo->{bidi}, 'L');
275is($charinfo->{decomposition}, '1F00 0345');
276is($charinfo->{decimal}, '');
277is($charinfo->{digit}, '');
278is($charinfo->{numeric}, '');
279is($charinfo->{mirrored}, 'N');
280is($charinfo->{unicode10}, '');
281is($charinfo->{comment}, '');
282is($charinfo->{upper}, '1F88');
283is($charinfo->{lower}, '');
284is($charinfo->{title}, '1F88');
285is($charinfo->{block}, 'Greek Extended');
286is($charinfo->{script}, 'Greek');
287
55d7b906 288use Unicode::UCD qw(charblocks charscripts);
10a6ecd2 289
b08cd201 290my $charblocks = charblocks();
10a6ecd2 291
f5c9f3db
JH
292ok(exists $charblocks->{Thai}, 'Thai charblock exists');
293is($charblocks->{Thai}->[0]->[0], hex('0e00'));
294ok(!exists $charblocks->{PigLatin}, 'PigLatin charblock does not exist');
10a6ecd2 295
b08cd201 296my $charscripts = charscripts();
10a6ecd2 297
f5c9f3db
JH
298ok(exists $charscripts->{Armenian}, 'Armenian charscript exists');
299is($charscripts->{Armenian}->[0]->[0], hex('0531'));
300ok(!exists $charscripts->{PigLatin}, 'PigLatin charscript does not exist');
10a6ecd2
JH
301
302my $charscript;
303
304$charscript = charscript("12ab");
f5c9f3db 305is($charscript, 'Ethiopic', 'Ethiopic charscript');
10a6ecd2
JH
306
307$charscript = charscript("0x12ab");
f5c9f3db 308is($charscript, 'Ethiopic');
10a6ecd2
JH
309
310$charscript = charscript("U+12ab");
f5c9f3db 311is($charscript, 'Ethiopic');
10a6ecd2
JH
312
313my $ranges;
314
315$ranges = charscript('Ogham');
7bccef0b
KW
316is($ranges->[0]->[0], hex('1680'), 'Ogham charscript');
317is($ranges->[0]->[1], hex('169C'));
10a6ecd2 318
55d7b906 319use Unicode::UCD qw(charinrange);
10a6ecd2
JH
320
321$ranges = charscript('Cherokee');
f5c9f3db 322ok(!charinrange($ranges, "139f"), 'Cherokee charscript');
10a6ecd2
JH
323ok( charinrange($ranges, "13a0"));
324ok( charinrange($ranges, "13f4"));
325ok(!charinrange($ranges, "13f5"));
326
ea508aee
JH
327use Unicode::UCD qw(general_categories);
328
329my $gc = general_categories();
330
331ok(exists $gc->{L}, 'has L');
332is($gc->{L}, 'Letter', 'L is Letter');
333is($gc->{Lu}, 'UppercaseLetter', 'Lu is UppercaseLetter');
334
335use Unicode::UCD qw(bidi_types);
336
337my $bt = bidi_types();
338
339ok(exists $bt->{L}, 'has L');
340is($bt->{L}, 'Left-to-Right', 'L is Left-to-Right');
341is($bt->{AL}, 'Right-to-Left Arabic', 'AL is Right-to-Left Arabic');
342
a452d459
KW
343# If this fails, then maybe one should look at the Unicode changes to see
344# what else might need to be updated.
7620cb10 345is(Unicode::UCD::UnicodeVersion, '6.1.0', 'UnicodeVersion');
b08cd201 346
55d7b906 347use Unicode::UCD qw(compexcl);
b08cd201 348
f5c9f3db 349ok(!compexcl(0x0100), 'compexcl');
71a442a8
KW
350ok(!compexcl(0xD801), 'compexcl of surrogate');
351ok(!compexcl(0x110000), 'compexcl of non-Unicode code point');
b08cd201
JH
352ok( compexcl(0x0958));
353
55d7b906 354use Unicode::UCD qw(casefold);
b08cd201
JH
355
356my $casefold;
357
358$casefold = casefold(0x41);
359
a452d459
KW
360is($casefold->{code}, '0041', 'casefold 0x41 code');
361is($casefold->{status}, 'C', 'casefold 0x41 status');
362is($casefold->{mapping}, '0061', 'casefold 0x41 mapping');
363is($casefold->{full}, '0061', 'casefold 0x41 full');
364is($casefold->{simple}, '0061', 'casefold 0x41 simple');
365is($casefold->{turkic}, "", 'casefold 0x41 turkic');
b08cd201
JH
366
367$casefold = casefold(0xdf);
368
a452d459
KW
369is($casefold->{code}, '00DF', 'casefold 0xDF code');
370is($casefold->{status}, 'F', 'casefold 0xDF status');
371is($casefold->{mapping}, '0073 0073', 'casefold 0xDF mapping');
372is($casefold->{full}, '0073 0073', 'casefold 0xDF full');
373is($casefold->{simple}, "", 'casefold 0xDF simple');
374is($casefold->{turkic}, "", 'casefold 0xDF turkic');
375
863a4fdf
KW
376# Do different tests depending on if version < 3.2, or not.
377my $v_unicode_version = pack "C*", split /\./, Unicode::UCD::UnicodeVersion();
378if ($v_unicode_version lt v3.2.0) {
a452d459
KW
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
418is($casefold->{code}, '1F88', 'casefold 0x1F88 code');
419is($casefold->{status}, 'S' , 'casefold 0x1F88 status');
420is($casefold->{mapping}, '1F80', 'casefold 0x1F88 mapping');
421is($casefold->{full}, '1F00 03B9', 'casefold 0x1F88 full');
422is($casefold->{simple}, '1F80', 'casefold 0x1F88 simple');
423is($casefold->{turkic}, "", 'casefold 0x1F88 turkic');
b08cd201
JH
424
425ok(!casefold(0x20));
426
55d7b906 427use Unicode::UCD qw(casespec);
b08cd201
JH
428
429my $casespec;
430
431ok(!casespec(0x41));
432
433$casespec = casespec(0xdf);
434
435ok($casespec->{code} eq '00DF' &&
436 $casespec->{lower} eq '00DF' &&
437 $casespec->{title} eq '0053 0073' &&
438 $casespec->{upper} eq '0053 0053' &&
2d3cf3ee 439 !defined $casespec->{condition}, 'casespec 0xDF');
b08cd201
JH
440
441$casespec = casespec(0x307);
442
f499c386 443ok($casespec->{az}->{code} eq '0307' &&
2d3cf3ee 444 !defined $casespec->{az}->{lower} &&
f499c386
JH
445 $casespec->{az}->{title} eq '0307' &&
446 $casespec->{az}->{upper} eq '0307' &&
9c3dc587 447 $casespec->{az}->{condition} eq 'az After_I',
f5c9f3db 448 'casespec 0x307');
6c8d78fb
HS
449
450# perl #7305 UnicodeCD::compexcl is weird
451
2d3cf3ee 452for (1) {my $a=compexcl $_}
6c8d78fb 453ok(1, 'compexcl read-only $_: perl #7305');
1f27373c 454map {compexcl $_} %{{1=>2}};
6c8d78fb
HS
455ok(1, 'compexcl read-only hash: perl #7305');
456
d7829152
JH
457is(Unicode::UCD::_getcode('123'), 123, "_getcode(123)");
458is(Unicode::UCD::_getcode('0123'), 0x123, "_getcode(0123)");
459is(Unicode::UCD::_getcode('0x123'), 0x123, "_getcode(0x123)");
460is(Unicode::UCD::_getcode('0X123'), 0x123, "_getcode(0X123)");
461is(Unicode::UCD::_getcode('U+123'), 0x123, "_getcode(U+123)");
462is(Unicode::UCD::_getcode('u+123'), 0x123, "_getcode(u+123)");
463is(Unicode::UCD::_getcode('U+1234'), 0x1234, "_getcode(U+1234)");
464is(Unicode::UCD::_getcode('U+12345'), 0x12345, "_getcode(U+12345)");
465is(Unicode::UCD::_getcode('123x'), undef, "_getcode(123x)");
466is(Unicode::UCD::_getcode('x123'), undef, "_getcode(x123)");
467is(Unicode::UCD::_getcode('0x123x'), undef, "_getcode(x123)");
468is(Unicode::UCD::_getcode('U+123x'), undef, "_getcode(x123)");
741297c1
JH
469
470{
471 my $r1 = charscript('Latin');
49ea58c8 472 if (ok(defined $r1, "Found Latin script")) {
f7ef59f7
KW
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");
49ea58c8 478 }
741297c1
JH
479}
480
c5a29f40
LM
481{
482 is(charinfo(0xdeadbeef), undef, "[perl #23273] warnings in Unicode::UCD");
2d3cf3ee 483}
a2bd7410
JH
484
485use Unicode::UCD qw(namedseq);
486
487is(namedseq("KATAKANA LETTER AINU P"), "\x{31F7}\x{309A}", "namedseq");
488is(namedseq("KATAKANA LETTER AINU Q"), undef);
489is(namedseq(), undef);
490is(namedseq(qw(foo bar)), undef);
491my @ns = namedseq("KATAKANA LETTER AINU P");
492is(scalar @ns, 2);
493is($ns[0], 0x31F7);
494is($ns[1], 0x309A);
495my %ns = namedseq();
496is($ns{"KATAKANA LETTER AINU P"}, "\x{31F7}\x{309A}");
497@ns = namedseq(42);
498is(@ns, 0);
499
7319f91d
KW
500use Unicode::UCD qw(num);
501use charnames ":full";
502
503is(num("0"), 0, 'Verify num("0") == 0');
504is(num("98765"), 98765, 'Verify num("98765") == 98765');
505ok(! defined num("98765\N{FULLWIDTH DIGIT FOUR}"), 'Verify num("98765\N{FULLWIDTH DIGIT FOUR}") isnt defined');
c4b3d89d
KW
506is(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');
507ok(! 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');
7319f91d
KW
508is(num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}"), 3, 'Verify num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}") == 3');
509ok(! defined num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}"), 'Verify num("\N{CHAM DIGIT ZERO}\N{JAVANESE DIGIT NINE}") isnt defined');
510is(num("\N{SUPERSCRIPT TWO}"), 2, 'Verify num("\N{SUPERSCRIPT TWO} == 2');
511is(num("\N{ETHIOPIC NUMBER TEN THOUSAND}"), 10000, 'Verify num("\N{ETHIOPIC NUMBER TEN THOUSAND}") == 10000');
512is(num("\N{NORTH INDIC FRACTION ONE HALF}"), .5, 'Verify num("\N{NORTH INDIC FRACTION ONE HALF}") == .5');
98025745 513is(num("\N{U+12448}"), 9, 'Verify num("\N{U+12448}") == 9');
4f143a72 514is(num("\N{U+5146}"), 1000000000000, 'Verify num("\N{U+5146}") == 1000000000000');
eaebe4db 515
7ef25837
KW
516# Create a user-defined property
517sub InKana {<<'END'}
5183040 309F
51930A0 30FF
520END
521
522use Unicode::UCD qw(prop_aliases);
523
524is(prop_aliases(undef), undef, "prop_aliases(undef) returns <undef>");
525is(prop_aliases("unknown property"), undef,
526 "prop_aliases(<unknown property>) returns <undef>");
527is(prop_aliases("InKana"), undef,
528 "prop_aliases(<user-defined property>) returns <undef>");
529is(prop_aliases("Perl_Decomposition_Mapping"), undef, "prop_aliases('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
530is(prop_aliases("Perl_Charnames"), undef,
531 "prop_aliases('Perl_Charnames') returns <undef> since internal-Perl-only");
532is(prop_aliases("isgc"), undef,
533 "prop_aliases('isgc') returns <undef> since is not covered Perl extension");
534is(prop_aliases("Is_Is_Any"), undef,
535 "prop_aliases('Is_Is_Any') returns <undef> since two is's");
536
537require 'utf8_heavy.pl';
538require "unicore/Heavy.pl";
539
540# Keys are lists of properties. Values are defined if have been tested.
541my %props;
542
543# To test for loose matching, add in the characters that are ignored there.
544my $extra_chars = "-_ ";
545
546# The one internal property we accept
547$props{'Perl_Decimal_Digit'} = 1;
548my @list = prop_aliases("perldecimaldigit");
549is_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.
0a2ae3b5
KW
555
556SKIP: {
557skip "PropertyAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
7ef25837
KW
558open my $props, "<", "../lib/unicore/PropertyAliases.txt"
559 or die "Can't open Unicode PropertyAliases.txt";
ce066323 560$/ = "\n";
7ef25837
KW
561while (<$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
e72b6605 576 my $loose = &utf8::_loose_name(lc $alias);
7ef25837
KW
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}
0a2ae3b5 623} # End of SKIP block
7ef25837
KW
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
629foreach my $alias (keys %utf8::loose_to_file_of) {
630 next if $alias =~ /=/;
631 my $lc_name = lc $alias;
e72b6605 632 my $loose = &utf8::_loose_name($lc_name);
7ef25837
KW
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);
e72b6605 637 my $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
7ef25837
KW
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) {
e72b6605 656 $found_it = grep { &utf8::_loose_name(lc $_) eq $lc_name } @aliases;
7ef25837
KW
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) {
e72b6605 663 $found_it = grep { &utf8::_loose_name(s/^In_(.*)/\L$1/r) eq $lc_name }
7ef25837
KW
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
674my $done_equals = 0;
675foreach 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
694use Unicode::UCD qw(prop_value_aliases);
695
696is(prop_value_aliases("unknown property", "unknown value"), undef,
697 "prop_value_aliases(<unknown property>, <unknown value>) returns <undef>");
698is(prop_value_aliases(undef, undef), undef,
699 "prop_value_aliases(undef, undef) returns <undef>");
700is((prop_value_aliases("na", "A")), "A", "test that prop_value_aliases returns its input for properties that don't have synonyms");
701is(prop_value_aliases("isgc", "C"), undef, "prop_value_aliases('isgc', 'C') returns <undef> since is not covered Perl extension");
702is(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
709my %pva_tested; # List of things already tested.
61b174f6
KW
710
711SKIP: {
712skip "PropValueAliases.txt is not in this Unicode version", 1 if $v_unicode_version lt v3.2.0;
7ef25837
KW
713open my $propvalues, "<", "../lib/unicore/PropValueAliases.txt"
714 or die "Can't open Unicode PropValueAliases.txt";
715while (<$propvalues>) {
716 s/\s*#.*//; # Remove comments
717 next if /^\s* $/x; # Ignore empty and comment lines
718 chomp;
719
74090492 720 # Fix typo in official input file
863a4fdf 721 s/CCC133/CCC132/g if $v_unicode_version eq v6.1.0;
74090492 722
7ef25837
KW
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]
e72b6605
KW
739 && &utf8::_loose_name(lc $fields[0])
740 eq &utf8::_loose_name(lc $fields[1])
7ef25837
KW
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
e72b6605 756 my $loose_prop = &utf8::_loose_name(lc $prop);
7ef25837
KW
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 }
e72b6605 764 elsif (grep { $_ eq ("$loose_prop=" . &utf8::_loose_name(lc $value)) } @Unicode::UCD::suppressed_properties) {
7ef25837
KW
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'");
e72b6605 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')");
7ef25837
KW
807 }
808
e72b6605 809 $pva_tested{&utf8::_loose_name(lc $prop) . "=" . &utf8::_loose_name(lc $value)} = 1;
7ef25837
KW
810 $count++;
811 }
812}
61b174f6 813} # End of SKIP block
7ef25837
KW
814
815# And test as best we can, the non-official pva's that mktables generates.
816foreach 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 {
e72b6605 860 ok((grep { &utf8::_loose_name(lc $_) eq &utf8::_loose_name(lc $value) }
7ef25837
KW
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
867undef %pva_tested;
868
681d705c
KW
869no warnings 'once'; # We use some values once from 'required' modules.
870
62b3b855
KW
871use 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.
887my $prop = "uc";
888my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
d11155ec 889is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
bf7fe2df 890is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
62b3b855 891is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
d11155ec 892is($invmap_ref->[1], 0x41, "prop_invmap('$prop') map[1] is 0x41");
62b3b855
KW
893
894$prop = "upper";
895($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop);
d11155ec
KW
896is($format, 's', "prop_invmap() format of '$prop' is 's");
897is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
62b3b855
KW
898is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
899is($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);
d11155ec
KW
903is($format, 's', "prop_invmap() format of '$prop' is 's'");
904is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
62b3b855
KW
905is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61");
906is($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);
d11155ec 910is($format, 'al', "prop_invmap() format of '$prop' is 'al'");
bf7fe2df 911is($missing, '0', "prop_invmap() missing of '$prop' is '0'");
62b3b855 912is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41");
d11155ec 913is($invmap_ref->[1], 0x61, "prop_invmap('$prop') map[1] is 0x61");
62b3b855
KW
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);
918is($format, 's', "prop_invmap() format of '$prop' is 's'");
919is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'");
920is_deeply($invlist_ref, [ 0x0000, 0x0030, 0x003A, 0x0041,
921 0x0047, 0x0061, 0x0067, 0x110000 ],
922 "prop_invmap('$prop') code point list is correct");
923is_deeply($invmap_ref, [ 'N', 'Y', 'N', 'Y', 'N', 'Y', 'N', 'N' ] ,
924 "prop_invmap('$prop') map list is correct");
681d705c
KW
925
926is(prop_invlist("Unknown property"), undef, "prop_invlist(<Unknown property>) returns undef");
927is(prop_invlist(undef), undef, "prop_invlist(undef) returns undef");
928is(prop_invlist("Any"), 2, "prop_invlist('Any') returns the number of elements in scalar context");
929my @invlist = prop_invlist("Is_Any");
930is_deeply(\@invlist, [ 0, 0x110000 ], "prop_invlist works on 'Is_' prefixes");
931is(prop_invlist("Is_Is_Any"), undef, "prop_invlist('Is_Is_Any') returns <undef> since two is's");
932
933use Storable qw(dclone);
934
935is(prop_invlist("InKana"), undef, "prop_invlist(<user-defined property returns undef>)");
936
62b3b855 937# The way both the tests for invlist and invmap work is that they take the
681d705c
KW
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
62b3b855 941# correct, but that invlist and invmap haven't introduced errors beyond what
681d705c
KW
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");
946is_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");
950is_deeply(\@invlist, [ 0x0000, 0x0030, 0x003A, 0x0041,
951 0x0047, 0x0061, 0x0067 ],
952 "prop_invlist('AHex=f') is exactly the expected set of points");
953
954sub 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
984my %tested_invlist;
985
986# Look at everything we think that mktables tells us exists, both loose and
987# strict
988foreach 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'
e72b6605 1119 $prop = &utf8::_loose_name($prop_only) =~ s/^is//r;
681d705c 1120 $prop = $utf8::loose_property_name_of{$prop};
e72b6605 1121 $prop .= "=" . &utf8::_loose_name($table);
681d705c
KW
1122 }
1123 else {
e72b6605 1124 $prop = &utf8::_loose_name($prop);
681d705c
KW
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
62b3b855
KW
1158# Now test prop_invmap().
1159
1160@list = prop_invmap("Unknown property");
1161is (@list, 0, "prop_invmap(<Unknown property>) returns an empty list");
1162@list = prop_invmap(undef);
1163is (@list, 0, "prop_invmap(undef) returns an empty list");
1164ok (! eval "prop_invmap('gc')" && $@ ne "",
1165 "prop_invmap('gc') dies in scalar context");
1166@list = prop_invmap("_X_Begin");
1167is (@list, 0, "prop_invmap(<internal property>) returns an empty list");
1168@list = prop_invmap("InKana");
1169is(@list, 0, "prop_invmap(<user-defined property returns undef>)");
1170@list = prop_invmap("Perl_Decomposition_Mapping"), undef,
1171is(@list, 0, "prop_invmap('Perl_Decomposition_Mapping') returns <undef> since internal-Perl-only");
1172@list = prop_invmap("Perl_Charnames"), undef,
1173is(@list, 0, "prop_invmap('Perl_Charnames') returns <undef> since internal-Perl-only");
1174@list = prop_invmap("Is_Is_Any");
1175is(@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
1180my %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
1195PROPERTY:
1196foreach my $prop (keys %props) {
e72b6605 1197 my $loose_prop = &utf8::_loose_name(lc $prop);
62b3b855
KW
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.
e72b6605 1213 $name = &utf8::_loose_name(lc $name);
62b3b855
KW
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 }
4f143a72 1276 elsif ($format =~ /^ a (?!r) /x) {
b0b13ada
KW
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") {
bf7fe2df
KW
1285 fail("prop_invmap('$mod_prop')");
1286 diag("The missings should be '0'; got '$missing'");
1287 next PROPERTY;
1288 }
1289 }
62b3b855
KW
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 }
d11155ec 1315 if ($format ne "a") {
62b3b855 1316 fail("prop_invmap('$mod_prop')");
d11155ec 1317 diag("The format should be 'a'; got '$format'");
62b3b855
KW
1318 next PROPERTY;
1319 }
1320 }
1321
5bbfa552
KW
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
62b3b855
KW
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 {
d11155ec 1372 $base_file = "Decomposition" if $format eq 'ad';
62b3b855
KW
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
62b3b855
KW
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
d11155ec 1397 if ($format eq 'ad') {
bea2c146
KW
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 }
62b3b855
KW
1419 }
1420 chomp $official;
1421
3eb27b83
KW
1422 # Get the format for the file, and if there are any special elements,
1423 # get a reference to them.
bf7fe2df
KW
1424 my $swash_name = $utf8::file_to_swash_name{$base_file};
1425 my $specials_ref;
3eb27b83 1426 my $file_format;
bf7fe2df
KW
1427 if ($swash_name) {
1428 $specials_ref = $utf8::SwashInfo{$swash_name}{'specials_name'};
62b3b855
KW
1429 if ($specials_ref) {
1430
1431 # Convert from the name to the actual reference.
1432 no strict 'refs';
1433 $specials_ref = \%{$specials_ref};
1434 }
3eb27b83
KW
1435
1436 $file_format = $utf8::SwashInfo{$swash_name}{'format'};
62b3b855
KW
1437 }
1438
1439 # Certain of the proxy properties have to be adjusted to match the
1440 # real ones.
ae1bcb1f 1441 if ($full_name =~ /^(Case_Folding|(Lower|Title|Upper)case_Mapping)/) {
62b3b855
KW
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 (.+?)
bea2c146 1455 \s* ( \# .* )? $ /x;
62b3b855 1456 $end = $start if $end eq "";
bf7fe2df 1457 push @list, [ hex $start, hex $end, $value ];
62b3b855
KW
1458 }
1459
ae1bcb1f 1460 # For these mappings, the file contains all the simple mappings,
62b3b855 1461 # including the ones that are overridden by the specials. These
ae1bcb1f 1462 # need to be removed as the list is for just the full ones.
62b3b855
KW
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
62b3b855
KW
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 ) {
bea2c146 1472 last if $cp <= $list[$i][1];
62b3b855
KW
1473 $i++;
1474 }
1475
bea2c146
KW
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]) {
62b3b855 1487
bea2c146
KW
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 }
62b3b855 1493
bea2c146
KW
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 }
62b3b855
KW
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.
bf7fe2df
KW
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 }
62b3b855 1521 }
ae1bcb1f
KW
1522 elsif ($full_name =~ /Simple_(Case_Folding|(Lower|Title|Upper)case_Mapping)/)
1523 {
62b3b855 1524
ae1bcb1f 1525 # These properties have everything in the regular array, and the
62b3b855 1526 # specials are superfluous.
ae1bcb1f 1527 undef $specials_ref;
62b3b855 1528 }
3eb27b83 1529 elsif ($format !~ /^a/ && defined $file_format && $file_format eq 'x') {
bf7fe2df 1530
3eb27b83
KW
1531 # For these properties the file is output using hex notation for the
1532 # map. Convert from hex to decimal.
bf7fe2df
KW
1533 my @lines = split "\n", $official;
1534 foreach my $line (@lines) {
3eb27b83
KW
1535 my ($lower, $upper, $map) = split "\t", $line;
1536 $line = "$lower\t$upper\t" . hex $map;
bf7fe2df
KW
1537 }
1538 $official = join "\n", @lines;
1539 }
62b3b855
KW
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.
bea2c146 1556 for (my $i = 0; $i < @$invlist_ref - 1; $i++) {
62b3b855
KW
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]
d11155ec 1562 && ($format eq 'ad' || $format =~ /^ . l /x))
62b3b855 1563 {
3b6a8189 1564 # The stringification depends on the format.
62b3b855 1565 if ($format eq 'sl') {
3b6a8189
KW
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 }
62b3b855 1595 }
d11155ec 1596 elsif ($format =~ / ^ al e? $/x) {
62b3b855 1597
d11155ec 1598 # For a al property, the stringified result should be in
62b3b855
KW
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 }
d11155ec 1626 elsif ($format eq 'ad') {
62b3b855
KW
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 }
d11155ec 1638 elsif ($format eq 'ad' || $format eq 'ale') {
34132297 1639
d11155ec
KW
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
34132297 1644 # $official, as these files, for backwards compatibility, are
d11155ec 1645 # not stored as adjusted. (There currently is only one ale
34132297 1646 # property, nfkccf. If that changed this would also have to.)
bea2c146
KW
1647 if ($invmap_ref->[$i] =~ / ^ -? \d+ $ /x
1648 && $invmap_ref->[$i] != 0)
1649 {
d11155ec
KW
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).
bea2c146
KW
1659 if ($invlist_ref->[$i+1] > $invlist_ref->[$i] + 1) {
1660 splice @$invlist_ref, $i+1, 0,
1661 $invlist_ref->[$i] + 1;
d11155ec 1662 splice @$invmap_ref, $i+1, 0, $next;
bea2c146
KW
1663 }
1664 }
d11155ec 1665 if ($format eq 'ale' && $invmap_ref->[$i] eq "") {
62b3b855 1666
d11155ec 1667 # ale properties have maps to the empty string that also
4066e594
KW
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 }
62b3b855 1681
4066e594
KW
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;
34132297 1693 }
62b3b855
KW
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
7f131b96
KW
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])
62b3b855 1721 {
7f131b96
KW
1722 fail("prop_invmap('$mod_prop')");
1723 diag(sprintf "Range beginning at %04X is out-of-order.", $invlist_ref->[$i]);
1724 next PROPERTY;
62b3b855 1725 }
7f131b96
KW
1726 next;
1727 }
62b3b855
KW
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
3b6a8189
KW
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.
62b3b855
KW
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
3b6a8189
KW
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.
62b3b855
KW
1786 $official =~ s/ 00000 \t .* 0001F .*? \n//xs;
1787 $official =~ s/ 0007F \t .* 0009F .*? \n//xs;
1788
3b6a8189
KW
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;
62b3b855
KW
1815 }
1816 }
62b3b855
KW
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 }
4f143a72 1917 elsif ($format eq 's') {
62b3b855
KW
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
eaebe4db 2012done_testing();