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