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