lib/Unicode/UCD.t

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