lib/Unicode/UCD.t

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