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