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