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