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