In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0ce5e53e761c7bd663b2e4d40e226a45b2d3911f?hp=65f0b1c95d7bf215dbc4072208126d472133a852>
- Log ----------------------------------------------------------------- commit 0ce5e53e761c7bd663b2e4d40e226a45b2d3911f Author: Karl Williamson <[email protected]> Date: Fri Feb 13 21:51:56 2015 -0700 Unicode::UCD: Generalize for EBCDIC platforms M charclass_invlists.h M lib/Unicode/UCD.pm M lib/Unicode/UCD.t M pod/perldelta.pod commit 31e72f274c2132a348b8278e4ac675d163f81449 Author: Karl Williamson <[email protected]> Date: Fri Feb 13 15:28:34 2015 -0700 Unicode::UCD::prop_aliases(): return correct long and short names Certain of the Perl extensions did not have the correct long and short names returned. M lib/Unicode/UCD.t M lib/unicore/mktables M pod/perldelta.pod commit a85d8148866d896e8ff49a47bf8baf9a26e3f2c0 Author: Karl Williamson <[email protected]> Date: Fri Feb 13 15:14:46 2015 -0700 mktables: Rip out redundant tables Experimentally, we changed the definition of Perl's space to include a vertical tab, thus being identical to the Posix space definition. In case we had to back this out, I left these as separate tables, but now that experiment is considered a success, and those tables can be collapsed. Later commits will finish up removing the experimental status of this. M lib/unicore/mktables commit 488cf33eb4b4b3f75055943801d383da718c7c9c Author: Karl Williamson <[email protected]> Date: Fri Feb 13 15:06:15 2015 -0700 mktables: Fix looping recursive detection This code was spuriously finding that the was a loop in what is being output. Use 'local' to fix it. M lib/unicore/mktables commit a78eaa96e6a046d1bb521be502a287fabb6bbc82 Author: Karl Williamson <[email protected]> Date: Fri Feb 13 11:08:30 2015 -0700 mktables: Remove unused variable M lib/unicore/mktables commit e1a3d014b7ff4ef8d8c2e3f5286c780f28a44bf0 Author: Karl Williamson <[email protected]> Date: Fri Feb 13 11:07:21 2015 -0700 mktables: Fix typo in comment M lib/unicore/mktables ----------------------------------------------------------------------- Summary of changes: charclass_invlists.h | 2 +- lib/Unicode/UCD.pm | 11 ++- lib/Unicode/UCD.t | 272 ++++++++++++++++++++++++++++++++++----------------- lib/unicore/mktables | 72 +++++--------- pod/perldelta.pod | 17 ++++ 5 files changed, 235 insertions(+), 139 deletions(-) diff --git a/charclass_invlists.h b/charclass_invlists.h index 603ffef..295119e 100644 --- a/charclass_invlists.h +++ b/charclass_invlists.h @@ -50101,7 +50101,7 @@ static const UV XPosixXDigit_invlist[] = { /* for EBCDIC POSIX-BC */ #endif /* EBCDIC POSIX-BC */ /* Generated from: - * 021d70af3d16a2ef4537c7cc60fa406179e07af3c260e61c346f51eb6430981a lib/Unicode/UCD.pm + * af5b38efe3edaef3597c50a9e3cc1e7d7d5d7fc9203256b48e99500cbc6f3ca1 lib/Unicode/UCD.pm * 827aa7ee45ca9fe09f3e0969a5a27a69ce58a6c7134548125266210018d27b49 lib/unicore/ArabicShaping.txt * 3748fbbe9d280a9da700bfd0c28beaaf6f32a67ec263a124fcb0a4095a30fae5 lib/unicore/BidiBrackets.txt * 3925329c2432fa7248b2e180cddcedb9a4f9eafbbb10ab9e105eaf833043b2fb lib/unicore/BidiMirroring.txt diff --git a/lib/Unicode/UCD.pm b/lib/Unicode/UCD.pm index 393de35..7e2ccf6 100644 --- a/lib/Unicode/UCD.pm +++ b/lib/Unicode/UCD.pm @@ -3530,8 +3530,15 @@ RETRY: # If the overrides came from SPECIALS, the code point keys are # packed UTF-8. if ($overrides == $swash->{'SPECIALS'}) { - $cp = unpack("C0U", $cp_maybe_utf8); - @map = unpack "U0U*", $swash->{'SPECIALS'}{$cp_maybe_utf8}; + $cp = $cp_maybe_utf8; + if (! utf8::decode($cp)) { + croak __PACKAGE__, "::prop_invmap: Malformed UTF-8: ", + map { sprintf("\\x{%02X}", unpack("C", $_)) } + split "", $cp; + } + + $cp = unpack("W", $cp); + @map = unpack "W*", $swash->{'SPECIALS'}{$cp_maybe_utf8}; # The empty string will show up unpacked as an empty # array. diff --git a/lib/Unicode/UCD.t b/lib/Unicode/UCD.t index 7a10849..e54c5ee 100644 --- a/lib/Unicode/UCD.t +++ b/lib/Unicode/UCD.t @@ -1,9 +1,7 @@ #!perl -w BEGIN { - if (ord("A") != 65) { - print "1..0 # Skip: EBCDIC\n"; - exit 0; - } + $::IS_ASCII = (ord("A") == 65) ? 1 : 0; + $::IS_EBCDIC = (ord("A") == 193) ? 1 : 0; chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; @@ -49,9 +47,11 @@ is($charinfo->{title}, ''); is($charinfo->{block}, 'Basic Latin'); is($charinfo->{script}, 'Common'); -$charinfo = charinfo(0x41); +my $A_code = sprintf("%04X", ord("A")); +my $a_code = sprintf("%04X", ord("a")); +$charinfo = charinfo(utf8::unicode_to_native(0x41)); -is($charinfo->{code}, '0041', 'LATIN CAPITAL LETTER A'); +is($charinfo->{code}, $A_code, 'LATIN CAPITAL LETTER A'); is($charinfo->{name}, 'LATIN CAPITAL LETTER A'); is($charinfo->{category}, 'Lu'); is($charinfo->{combining}, '0'); @@ -64,7 +64,7 @@ is($charinfo->{mirrored}, 'N'); is($charinfo->{unicode10}, ''); is($charinfo->{comment}, ''); is($charinfo->{upper}, ''); -is($charinfo->{lower}, '0061'); +is($charinfo->{lower}, $a_code); is($charinfo->{title}, ''); is($charinfo->{block}, 'Basic Latin'); is($charinfo->{script}, 'Latin'); @@ -76,7 +76,7 @@ is($charinfo->{name}, 'LATIN CAPITAL LETTER A WITH MACRON'); is($charinfo->{category}, 'Lu'); is($charinfo->{combining}, '0'); is($charinfo->{bidi}, 'L'); -is($charinfo->{decomposition}, '0041 0304'); +is($charinfo->{decomposition}, "$A_code 0304"); is($charinfo->{decimal}, ''); is($charinfo->{digit}, ''); is($charinfo->{numeric}, ''); @@ -184,7 +184,7 @@ is($charinfo->{name}, 'MATHEMATICAL BOLD CAPITAL A'); is($charinfo->{category}, 'Lu'); is($charinfo->{combining}, '0'); is($charinfo->{bidi}, 'L'); -is($charinfo->{decomposition}, '<font> 0041'); +is($charinfo->{decomposition}, "<font> $A_code"); is($charinfo->{decimal}, ''); is($charinfo->{digit}, ''); is($charinfo->{numeric}, ''); @@ -225,14 +225,18 @@ is(charblock(0x590), 'Hebrew', '0x0590 - Hebrew unused charblock'); is(charscript(0x590), 'Unknown', '0x0590 - Hebrew unused charscript'); is(charblock(0x1FFFF), 'No_Block', '0x1FFFF - unused charblock'); -$charinfo = charinfo(0xbe); +my $fraction_3_4_code = sprintf("%04X", utf8::unicode_to_native(0xbe)); +$charinfo = charinfo(hex $fraction_3_4_code); -is($charinfo->{code}, '00BE', 'VULGAR FRACTION THREE QUARTERS'); +is($charinfo->{code}, $fraction_3_4_code, 'VULGAR FRACTION THREE QUARTERS'); is($charinfo->{name}, 'VULGAR FRACTION THREE QUARTERS'); is($charinfo->{category}, 'No'); is($charinfo->{combining}, '0'); is($charinfo->{bidi}, 'ON'); -is($charinfo->{decomposition}, '<fraction> 0033 2044 0034'); +is($charinfo->{decomposition}, '<fraction> ' + . sprintf("%04X", ord "3") + . " 2044 " + . sprintf("%04X", ord "4")); is($charinfo->{decimal}, ''); is($charinfo->{digit}, ''); is($charinfo->{numeric}, '3/4'); @@ -248,13 +252,15 @@ is($charinfo->{script}, 'Common'); # This is to test a case where both simple and full lowercases exist and # differ $charinfo = charinfo(0x130); +my $I_code = sprintf("%04X", ord("I")); +my $i_code = sprintf("%04X", ord("i")); is($charinfo->{code}, '0130', 'LATIN CAPITAL LETTER I WITH DOT ABOVE'); is($charinfo->{name}, 'LATIN CAPITAL LETTER I WITH DOT ABOVE'); is($charinfo->{category}, 'Lu'); is($charinfo->{combining}, '0'); is($charinfo->{bidi}, 'L'); -is($charinfo->{decomposition}, '0049 0307'); +is($charinfo->{decomposition}, "$I_code 0307"); is($charinfo->{decimal}, ''); is($charinfo->{digit}, ''); is($charinfo->{numeric}, ''); @@ -262,7 +268,7 @@ is($charinfo->{mirrored}, 'N'); is($charinfo->{unicode10}, 'LATIN CAPITAL LETTER I DOT'); is($charinfo->{comment}, ''); is($charinfo->{upper}, ''); -is($charinfo->{lower}, '0069'); +is($charinfo->{lower}, $i_code); is($charinfo->{title}, ''); is($charinfo->{block}, 'Latin Extended-A'); is($charinfo->{script}, 'Latin'); @@ -359,23 +365,26 @@ use Unicode::UCD qw(casefold); my $casefold; -$casefold = casefold(0x41); +$casefold = casefold(utf8::unicode_to_native(0x41)); -is($casefold->{code}, '0041', 'casefold 0x41 code'); -is($casefold->{status}, 'C', 'casefold 0x41 status'); -is($casefold->{mapping}, '0061', 'casefold 0x41 mapping'); -is($casefold->{full}, '0061', 'casefold 0x41 full'); -is($casefold->{simple}, '0061', 'casefold 0x41 simple'); -is($casefold->{turkic}, "", 'casefold 0x41 turkic'); +is($casefold->{code}, $A_code, 'casefold native(0x41) code'); +is($casefold->{status}, 'C', 'casefold native(0x41) status'); +is($casefold->{mapping}, $a_code, 'casefold native(0x41) mapping'); +is($casefold->{full}, $a_code, 'casefold native(0x41) full'); +is($casefold->{simple}, $a_code, 'casefold native(0x41) simple'); +is($casefold->{turkic}, "", 'casefold native(0x41) turkic'); -$casefold = casefold(0xdf); +$casefold = casefold(utf8::unicode_to_native(0xdf)); +my $sharp_s_code = sprintf("%04X", utf8::unicode_to_native(0xdf)); +my $S_code = sprintf("%04X", ord "S"); +my $s_code = sprintf("%04X", ord "s"); -is($casefold->{code}, '00DF', 'casefold 0xDF code'); -is($casefold->{status}, 'F', 'casefold 0xDF status'); -is($casefold->{mapping}, '0073 0073', 'casefold 0xDF mapping'); -is($casefold->{full}, '0073 0073', 'casefold 0xDF full'); -is($casefold->{simple}, "", 'casefold 0xDF simple'); -is($casefold->{turkic}, "", 'casefold 0xDF turkic'); +is($casefold->{code}, $sharp_s_code, 'casefold native(0xDF) code'); +is($casefold->{status}, 'F', 'casefold native(0xDF) status'); +is($casefold->{mapping}, "$s_code $s_code", 'casefold native(0xDF) mapping'); +is($casefold->{full}, "$s_code $s_code", 'casefold native(0xDF) full'); +is($casefold->{simple}, "", 'casefold native(0xDF) simple'); +is($casefold->{turkic}, "", 'casefold native(0xDF) turkic'); # Do different tests depending on if version < 3.2, or not. my $v_unicode_version = pack "C*", split /\./, Unicode::UCD::UnicodeVersion(); @@ -384,37 +393,37 @@ if ($v_unicode_version lt v3.2.0) { is($casefold->{code}, '0130', 'casefold 0x130 code'); is($casefold->{status}, 'I' , 'casefold 0x130 status'); - is($casefold->{mapping}, '0069', 'casefold 0x130 mapping'); - is($casefold->{full}, '0069', 'casefold 0x130 full'); - is($casefold->{simple}, "0069", 'casefold 0x130 simple'); - is($casefold->{turkic}, "0069", 'casefold 0x130 turkic'); + is($casefold->{mapping}, $i_code, 'casefold 0x130 mapping'); + is($casefold->{full}, $i_code, 'casefold 0x130 full'); + is($casefold->{simple}, $i_code, 'casefold 0x130 simple'); + is($casefold->{turkic}, $i_code, 'casefold 0x130 turkic'); $casefold = casefold(0x131); is($casefold->{code}, '0131', 'casefold 0x131 code'); is($casefold->{status}, 'I' , 'casefold 0x131 status'); - is($casefold->{mapping}, '0069', 'casefold 0x131 mapping'); - is($casefold->{full}, '0069', 'casefold 0x131 full'); - is($casefold->{simple}, "0069", 'casefold 0x131 simple'); - is($casefold->{turkic}, "0069", 'casefold 0x131 turkic'); + is($casefold->{mapping}, $i_code, 'casefold 0x131 mapping'); + is($casefold->{full}, $i_code, 'casefold 0x131 full'); + is($casefold->{simple}, $i_code, 'casefold 0x131 simple'); + is($casefold->{turkic}, $i_code, 'casefold 0x131 turkic'); } else { - $casefold = casefold(0x49); + $casefold = casefold(utf8::unicode_to_native(0x49)); - is($casefold->{code}, '0049', 'casefold 0x49 code'); - is($casefold->{status}, 'C' , 'casefold 0x49 status'); - is($casefold->{mapping}, '0069', 'casefold 0x49 mapping'); - is($casefold->{full}, '0069', 'casefold 0x49 full'); - is($casefold->{simple}, "0069", 'casefold 0x49 simple'); - is($casefold->{turkic}, "0131", 'casefold 0x49 turkic'); + is($casefold->{code}, $I_code, 'casefold native(0x49) code'); + is($casefold->{status}, 'C' , 'casefold native(0x49) status'); + is($casefold->{mapping}, $i_code, 'casefold native(0x49) mapping'); + is($casefold->{full}, $i_code, 'casefold native(0x49) full'); + is($casefold->{simple}, $i_code, 'casefold native(0x49) simple'); + is($casefold->{turkic}, "0131", 'casefold native(0x49) turkic'); $casefold = casefold(0x130); is($casefold->{code}, '0130', 'casefold 0x130 code'); is($casefold->{status}, 'F' , 'casefold 0x130 status'); - is($casefold->{mapping}, '0069 0307', 'casefold 0x130 mapping'); - is($casefold->{full}, '0069 0307', 'casefold 0x130 full'); + is($casefold->{mapping}, "$i_code 0307", 'casefold 0x130 mapping'); + is($casefold->{full}, "$i_code 0307", 'casefold 0x130 full'); is($casefold->{simple}, "", 'casefold 0x130 simple'); - is($casefold->{turkic}, "0069", 'casefold 0x130 turkic'); + is($casefold->{turkic}, $i_code, 'casefold 0x130 turkic'); } $casefold = casefold(0x1F88); @@ -426,21 +435,21 @@ is($casefold->{full}, '1F00 03B9', 'casefold 0x1F88 full'); is($casefold->{simple}, '1F80', 'casefold 0x1F88 simple'); is($casefold->{turkic}, "", 'casefold 0x1F88 turkic'); -ok(!casefold(0x20)); +ok(!casefold(utf8::unicode_to_native(0x20))); use Unicode::UCD qw(casespec); my $casespec; -ok(!casespec(0x41)); +ok(!casespec(utf8::unicode_to_native(0x41))); -$casespec = casespec(0xdf); +$casespec = casespec(utf8::unicode_to_native(0xdf)); -ok($casespec->{code} eq '00DF' && - $casespec->{lower} eq '00DF' && - $casespec->{title} eq '0053 0073' && - $casespec->{upper} eq '0053 0053' && - !defined $casespec->{condition}, 'casespec 0xDF'); +ok($casespec->{code} eq $sharp_s_code && + $casespec->{lower} eq $sharp_s_code && + $casespec->{title} eq "$S_code $s_code" && + $casespec->{upper} eq "$S_code $S_code" && + !defined $casespec->{condition}, 'casespec native(0xDF)'); $casespec = casespec(0x307); @@ -475,7 +484,7 @@ is(Unicode::UCD::_getcode('U+123x'), undef, "_getcode(x123)"); my $r1 = charscript('Latin'); if (ok(defined $r1, "Found Latin script")) { my $n1 = @$r1; - is($n1, 33, "number of ranges in Latin script (Unicode 7.0.0)"); + is($n1, 33, "number of ranges in Latin script (Unicode 7.0.0)") if $::IS_ASCII; shift @$r1 while @$r1; my $r2 = charscript('Latin'); is(@$r2, $n1, "modifying results should not mess up internal caches"); @@ -507,6 +516,8 @@ use charnames ":full"; is(num("0"), 0, 'Verify num("0") == 0'); is(num("98765"), 98765, 'Verify num("98765") == 98765'); ok(! defined num("98765\N{FULLWIDTH DIGIT FOUR}"), 'Verify num("98765\N{FULLWIDTH DIGIT FOUR}") isnt defined'); +is(num("\N{NEW TAI LUE DIGIT TWO}"), 2, 'Verify num("\N{NEW TAI LUE DIGIT TWO}") == 2'); +is(num("\N{NEW TAI LUE DIGIT ONE}"), 1, 'Verify num("\N{NEW TAI LUE DIGIT ONE}") == 1'); is(num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}"), 21, 'Verify num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE DIGIT ONE}") == 21'); ok(! defined num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}"), 'Verify num("\N{NEW TAI LUE DIGIT TWO}\N{NEW TAI LUE THAM DIGIT ONE}") isnt defined'); is(num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}"), 3, 'Verify num("\N{CHAM DIGIT ZERO}\N{CHAM DIGIT THREE}") == 3'); @@ -678,6 +689,15 @@ foreach my $alias (sort keys %utf8::loose_to_file_of) { } } +# Some of the Perl extensions should always be built; make sure they have the +# correct full name, etc. +for my $prop (qw(Alnum Blank Cntrl Digit Graph Print Word XDigit)) { + my @expected = ( $prop, "XPosix$prop" ); + my @got = prop_aliases($prop); + splice @got, 2; + is_deeply(\@got, \@expected, "Got expected aliases for $prop"); +} + my $done_equals = 0; foreach my $alias (keys %utf8::stricter_to_file_of) { if ($alias =~ /=/) { # Only test one case where there is an equals @@ -921,8 +941,13 @@ use Unicode::UCD qw(prop_invlist prop_invmap MAX_CP); # elements are; just look at the first element to see if are getting the # distinction right. The general inversion map testing below will test the # whole thing. -my $prop = "uc"; -my ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop); + +my $prop; +my ($invlist_ref, $invmap_ref, $format, $missing); +if ($::IS_ASCII) { # On EBCDIC, other things will come first, and can vary + # according to code page +$prop = "uc"; +($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop); is($format, 'al', "prop_invmap() format of '$prop' is 'al'"); is($missing, '0', "prop_invmap() missing of '$prop' is '0'"); is($invlist_ref->[1], 0x61, "prop_invmap('$prop') list[1] is 0x61"); @@ -948,15 +973,30 @@ is($format, 'al', "prop_invmap() format of '$prop' is 'al'"); is($missing, '0', "prop_invmap() missing of '$prop' is '0'"); is($invlist_ref->[1], 0x41, "prop_invmap('$prop') list[1] is 0x41"); is($invmap_ref->[1], 0x61, "prop_invmap('$prop') map[1] is 0x61"); +} # This property is stable and small, so can test all of it $prop = "ASCII_Hex_Digit"; ($invlist_ref, $invmap_ref, $format, $missing) = prop_invmap($prop); is($format, 's', "prop_invmap() format of '$prop' is 's'"); is($missing, 'N', "prop_invmap() missing of '$prop' is 'N'"); -is_deeply($invlist_ref, [ 0x0000, 0x0030, 0x003A, 0x0041, - 0x0047, 0x0061, 0x0067, 0x110000 ], +if ($::IS_ASCII) { + is_deeply($invlist_ref, [ 0x0000, 0x0030, 0x003A, + 0x0041, 0x0047, + 0x0061, 0x0067, 0x110000 + ], "prop_invmap('$prop') code point list is correct"); +} +elsif ($::IS_EBCDIC) { + is_deeply($invlist_ref, [ + utf8::unicode_to_native(0x0000), + utf8::unicode_to_native(0x0061), utf8::unicode_to_native(0x0066) + 1, + utf8::unicode_to_native(0x0041), utf8::unicode_to_native(0x0046) + 1, + utf8::unicode_to_native(0x0030), utf8::unicode_to_native(0x0039) + 1, + utf8::unicode_to_native(0x110000) + ], + "prop_invmap('$prop') code point list is correct"); +} is_deeply($invmap_ref, [ 'N', 'Y', 'N', 'Y', 'N', 'Y', 'N', 'N' ] , "prop_invmap('$prop') map list is correct"); @@ -979,14 +1019,37 @@ is(prop_invlist("InKana"), undef, "prop_invlist(<user-defined property returns u # are there in the files. As a small hedge against that, test some # prop_invlist() tables fully with the known correct result. We choose # ASCII_Hex_Digit again, as it is stable. -@invlist = prop_invlist("AHex"); -is_deeply(\@invlist, [ 0x0030, 0x003A, 0x0041, +if ($::IS_ASCII) { + @invlist = prop_invlist("AHex"); + is_deeply(\@invlist, [ 0x0030, 0x003A, 0x0041, 0x0047, 0x0061, 0x0067 ], "prop_invlist('AHex') is exactly the expected set of points"); -@invlist = prop_invlist("AHex=f"); -is_deeply(\@invlist, [ 0x0000, 0x0030, 0x003A, 0x0041, + @invlist = prop_invlist("AHex=f"); + is_deeply(\@invlist, [ 0x0000, 0x0030, 0x003A, 0x0041, 0x0047, 0x0061, 0x0067 ], "prop_invlist('AHex=f') is exactly the expected set of points"); +} +elsif ($::IS_EBCDIC) { # Relies on the ranges 0-9, a-f, and A-F each being + # contiguous + @invlist = prop_invlist("AHex"); + is_deeply(\@invlist, [ + utf8::unicode_to_native(0x0061), utf8::unicode_to_native(0x0066) + 1, + utf8::unicode_to_native(0x0041), utf8::unicode_to_native(0x0046) + 1, + utf8::unicode_to_native(0x0030), utf8::unicode_to_native(0x0039) + 1, + ], + "prop_invlist('AHex') is exactly the expected set of points"); + @invlist = prop_invlist("AHex=f"); + is_deeply(\@invlist, [ + utf8::unicode_to_native(0x0000), + utf8::unicode_to_native(0x0061), + utf8::unicode_to_native(0x0066) + 1, + utf8::unicode_to_native(0x0041), + utf8::unicode_to_native(0x0046) + 1, + utf8::unicode_to_native(0x0030), + utf8::unicode_to_native(0x0039) + 1, + ], + "prop_invlist('AHex=f') is exactly the expected set of points"); +} sub fail_with_diff ($$$$) { # For use below to output better messages @@ -1480,23 +1543,46 @@ foreach my $prop (sort(keys %props), sort keys %legacy_props) { if ($name eq 'blk') { # The blk property is special. The original file with old block - # names is retained, and the default is to not write out a - # new-name file. What we do is get the old names into a data - # structure, and from that create what the new file would look - # like. $base_file is needed to be defined, just to avoid a - # message below. + # names is retained, and the default (on ASCII platforms) is to + # not write out a new-name file. What we do is get the old names + # into a data structure, and from that create what the new file + # would look like. $base_file is needed to be defined, just to + # avoid a message below. $base_file = "This is a dummy name"; my $blocks_ref = charblocks(); + + if ($::IS_EBCDIC) { + # On EBCDIC, the first two blocks can each contain multiple + # ranges. We create a new version with each of these + # flattened, so have one level. ($index is used as a dummy + # key.) + my %new_blocks; + my $index = 0; + foreach my $block (values %$blocks_ref) { + foreach my $range (@$block) { + $new_blocks{$index++}[0] = $range; + } + } + $blocks_ref = \%new_blocks; + } $official = ""; for my $range (sort { $a->[0][0] <=> $b->[0][0] } values %$blocks_ref) { # Translate the charblocks() data structure to what the file - # would like. - $official .= sprintf"%X\t%X\t%s\n", - $range->[0][0], - $range->[0][1], - $range->[0][2]; + # would look like. (The sub range is for EBCDIC platforms + # where Latin1 and ASCII are intermixed.) + if ($range->[0][0] == $range->[0][1]) { + $official .= sprintf("%X\t\t%s\n", + $range->[0][0], + $range->[0][2]); + } + else { + $official .= sprintf("%X\t%X\t%s\n", + $range->[0][0], + $range->[0][1], + $range->[0][2]); + } } } else { @@ -1615,10 +1701,13 @@ foreach my $prop (sort(keys %props), sort keys %legacy_props) { # including the ones that are overridden by the specials. These # need to be removed as the list is for just the full ones. - # Go through any special mappings one by one. They are packed. + # Go through any special mappings one by one. The keys are the + # UTF-8 representation of code points. my $i = 0; foreach my $utf8_cp (sort keys %$specials_ref) { - my $cp = unpack("C0U", $utf8_cp); + my $cp = $utf8_cp; + utf8::decode($cp); + $cp = ord $cp; # Find the spot in the @list of simple mappings that this # special applies to; uses a linear search. @@ -1764,17 +1853,18 @@ foreach my $prop (sort(keys %props), sort keys %legacy_props) { elsif ($format =~ / ^ al e? $/x) { # For an al property, the stringified result should be in - # the specials hash. The key is the packed code point, - # and the value is the packed map. + # the specials hash. The key is the utf8 bytes of the + # code point, and the value is its map as a utf-8 string. my $value; - if (! defined ($value = delete $specials{pack("C0U", - $invlist_ref->[$i]) })) - { + my $key = chr $invlist_ref->[$i]; + utf8::encode($key); + if (! defined ($value = delete $specials{$key})) { fail("prop_invmap('$display_prop')"); diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]); next PROPERTY; } - my $packed = pack "U*", @{$invmap_ref->[$i]}; + my $packed = pack "W*", @{$invmap_ref->[$i]}; + utf8::upgrade($packed); if ($value ne $packed) { fail("prop_invmap('$display_prop')"); diag(sprintf "For %04X, expected the mapping to be " @@ -1842,12 +1932,12 @@ foreach my $prop (sort(keys %props), sort keys %legacy_props) { if ($format eq 'ale' && $invmap_ref->[$i] eq "") { # ale properties have maps to the empty string that also - # should be in the specials hash, with the key the packed - # code point, and the map just empty. + # should be in the specials hash, with the key the utf8 + # bytes representing the code point, and the map just empty. my $value; - if (! defined ($value = delete $specials{pack("C0U", - $invlist_ref->[$i]) })) - { + my $key = chr $invlist_ref->[$i]; + utf8::encode($key); + if (! defined ($value = delete $specials{$key})) { fail("prop_invmap('$display_prop')"); diag(sprintf "There was no specials element for %04X", $invlist_ref->[$i]); next PROPERTY; @@ -1986,8 +2076,14 @@ foreach my $prop (sort(keys %props), sort keys %legacy_props) { # shouldn't be in the property. This gets rid of the two ranges in # one fell swoop, and also all the Unicode1_Name values that may not # be in Name_Alias. - $official =~ s/ 00000 \t .* 0001F .*? \n//xs; - $official =~ s/ 0007F \t .* 0009F .*? \n//xs; + if ($::IS_ASCII) { + $official =~ s/ 00000 \t .* 0001F .*? \n//xs; + $official =~ s/ 0007F \t .* 0009F .*? \n//xs; + } + elsif ($::IS_EBCDIC) { # Won't work for POSIX-BC + $official =~ s/ 00000 \t .* 0003F .*? \n//xs; + $official =~ s/ 000FF \t .* 000FF .*? \n//xs; + } # And remove the aliases. We read in the Name_Alias property, and go # through them one by one. diff --git a/lib/unicore/mktables b/lib/unicore/mktables index 119df82..e839576 100644 --- a/lib/unicore/mktables +++ b/lib/unicore/mktables @@ -9273,7 +9273,7 @@ sub utf8_heavy_name ($$) { { # Closure my $indent_increment = " " x (($debugging_build) ? 2 : 0); - my %already_output; + %main::already_output = (); $main::simple_dumper_nesting = 0; @@ -9293,7 +9293,7 @@ sub utf8_heavy_name ($$) { # nesting level is localized, so that as the call stack pops, it goes # back to the prior value. local $main::simple_dumper_nesting = $main::simple_dumper_nesting; - undef %already_output if $main::simple_dumper_nesting == 0; + local %main::already_output = %main::already_output; $main::simple_dumper_nesting++; #print STDERR __LINE__, ": $main::simple_dumper_nesting: $indent$item\n"; @@ -9324,10 +9324,10 @@ sub utf8_heavy_name ($$) { # Keep track of cycles in the input, and refuse to infinitely loop my $addr = do { no overloading; pack 'J', $item; }; - if (defined $already_output{$addr}) { + if (defined $main::already_output{$addr}) { return "${indent}ALREADY OUTPUT: $item\n"; } - $already_output{$addr} = $item; + $main::already_output{$addr} = $item; if (ref $item eq 'ARRAY') { my $using_brackets; @@ -13418,7 +13418,7 @@ sub compile_perl() { # have Uppercase and Lowercase defined, so use the general category # instead for them, modified by hard-coding in the code points each is # missing. - my $Lower = $perl->add_match_table('Lower'); + my $Lower = $perl->add_match_table('XPosixLower'); my $Unicode_Lower = property_ref('Lowercase'); if (defined $Unicode_Lower && ! $Unicode_Lower->is_empty) { $Lower->set_equivalent_to($Unicode_Lower->table('Y'), Related => 1); @@ -13456,13 +13456,12 @@ sub compile_perl() { $Lower += $code_point; } } - $Lower->add_alias('XPosixLower'); my $Posix_Lower = $perl->add_match_table("PosixLower", Description => "[a-z]", Initialize => $Lower & $ASCII, ); - my $Upper = $perl->add_match_table('Upper'); + my $Upper = $perl->add_match_table("XPosixUpper"); my $Unicode_Upper = property_ref('Uppercase'); if (defined $Unicode_Upper && ! $Unicode_Upper->is_empty) { $Upper->set_equivalent_to($Unicode_Upper->table('Y'), Related => 1); @@ -13475,7 +13474,6 @@ sub compile_perl() { $Upper->add_range(0x2160, 0x216F); # Uppercase Roman numerals $Upper->add_range(0x24B6, 0x24CF); # Circled Latin upper case letters } - $Upper->add_alias('XPosixUpper'); my $Posix_Upper = $perl->add_match_table("PosixUpper", Description => "[A-Z]", Initialize => $Upper & $ASCII, @@ -13597,7 +13595,7 @@ sub compile_perl() { # one whose name generally begins with Posix that is posix-compliant, and # one that matches Unicode characters beyond the Posix, ASCII range - my $Alpha = $perl->add_match_table('Alpha'); + my $Alpha = $perl->add_match_table('XPosixAlpha'); # Alphabetic was not present in early releases my $Alphabetic = property_ref('Alphabetic'); @@ -13684,7 +13682,6 @@ sub compile_perl() { $Alpha->add_description('Alphabetic'); $Alpha->add_alias('Alphabetic'); } - $Alpha->add_alias('XPosixAlpha'); my $Posix_Alpha = $perl->add_match_table("PosixAlpha", Description => "[A-Za-z]", Initialize => $Alpha & $ASCII, @@ -13692,22 +13689,20 @@ sub compile_perl() { $Posix_Upper->set_caseless_equivalent($Posix_Alpha); $Posix_Lower->set_caseless_equivalent($Posix_Alpha); - my $Alnum = $perl->add_match_table('Alnum', + my $Alnum = $perl->add_match_table('Alnum', Full_Name => 'XPosixAlnum', Description => 'Alphabetic and (decimal) Numeric', Initialize => $Alpha + $gc->table('Decimal_Number'), ); - $Alnum->add_alias('XPosixAlnum'); $perl->add_match_table("PosixAlnum", Description => "[A-Za-z0-9]", Initialize => $Alnum & $ASCII, ); - my $Word = $perl->add_match_table('Word', + my $Word = $perl->add_match_table('Word', Full_Name => 'XPosixWord', Description => '\w, including beyond ASCII;' . ' = \p{Alnum} + \pM + \p{Pc}', Initialize => $Alnum + $gc->table('Mark'), ); - $Word->add_alias('XPosixWord'); my $Pc = $gc->table('Connector_Punctuation'); # 'Pc' Not in release 1 if (defined $Pc) { $Word += $Pc; @@ -13724,13 +13719,13 @@ sub compile_perl() { } # This is a Perl extension, so the name doesn't begin with Posix. - my $PerlWord = $perl->add_match_table('PerlWord', + my $PerlWord = $perl->add_match_table('PosixWord', Description => '\w, restricted to ASCII = [A-Za-z0-9_]', Initialize => $Word & $ASCII, ); - $PerlWord->add_alias('PosixWord'); + $PerlWord->add_alias('PerlWord'); - my $Blank = $perl->add_match_table('Blank', + my $Blank = $perl->add_match_table('Blank', Full_Name => 'XPosixBlank', Description => '\h, Horizontal white space', # 200B is Zero Width Space which is for line @@ -13741,7 +13736,6 @@ sub compile_perl() { - 0x200B, # ZWSP ); $Blank->add_alias('HorizSpace'); # Another name for it. - $Blank->add_alias('XPosixBlank'); $perl->add_match_table("PosixBlank", Description => "\\t and ' '", Initialize => $Blank & $ASCII, @@ -13760,34 +13754,22 @@ sub compile_perl() { ); # No Posix equivalent for vertical space - my $Space = $perl->add_match_table('Space', + my $Space = $perl->add_match_table('XPosixSpace', Description => '\s including beyond ASCII and vertical tab', Initialize => $Blank + $VertSpace, ); - $Space->add_alias('XPosixSpace'); - my $posix_space = $perl->add_match_table("PosixSpace", + $Space->add_alias('XPerlSpace'); # Pre-existing synonyms + $Space->add_alias('SpacePerl'); + + my $Posix_space = $perl->add_match_table("PosixSpace", Description => "\\t, \\n, \\cK, \\f, \\r, and ' '. (\\cK is vertical tab)", Initialize => $Space & $ASCII, ); + $Posix_space->add_alias('PerlSpace'); # A pre-existing synonym - # Perl's traditional space doesn't include Vertical Tab prior to v5.18 - my $XPerlSpace = $perl->add_match_table('XPerlSpace', - Description => '\s, including beyond ASCII', - Initialize => $Space, - #Initialize => $Space - # - utf8::unicode_to_native(0x0B] - ); - $XPerlSpace->add_alias('SpacePerl'); # A pre-existing synonym - my $PerlSpace = $perl->add_match_table('PerlSpace', - Description => '\s, restricted to ASCII = [ \f\n\r\t] plus vertical tab', - Initialize => $XPerlSpace & $ASCII, - ); - - - my $Cntrl = $perl->add_match_table('Cntrl', + my $Cntrl = $perl->add_match_table('Cntrl', Full_Name => 'XPosixCntrl', Description => 'Control characters'); $Cntrl->set_equivalent_to($gc->table('Cc'), Related => 1); - $Cntrl->add_alias('XPosixCntrl'); $perl->add_match_table("PosixCntrl", Description => "ASCII control characters: NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS, HT, LF, VT, FF, CR, SO, SI, DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EOM, SUB, ES ... [28 chars truncated] Initialize => $Cntrl & $ASCII, @@ -13800,22 +13782,20 @@ sub compile_perl() { $controls += $gc->table('Surrogate') if defined $gc->table('Surrogate'); # Graph is ~space & ~(Cc|Cs|Cn) = ~(space + $controls) - my $Graph = $perl->add_match_table('Graph', + my $Graph = $perl->add_match_table('Graph', Full_Name => 'XPosixGraph', Description => 'Characters that are graphical', Initialize => ~ ($Space + $controls), ); - $Graph->add_alias('XPosixGraph'); $perl->add_match_table("PosixGraph", Description => '[-!"#$%&\'()*+,./:;<=>?@[\\\]^_`{|}~0-9A-Za-z]', Initialize => $Graph & $ASCII, ); - $print = $perl->add_match_table('Print', + $print = $perl->add_match_table('Print', Full_Name => 'XPosixPrint', Description => 'Characters that are graphical plus space characters (but no controls)', Initialize => $Blank + $Graph - $gc->table('Control'), ); - $print->add_alias('XPosixPrint'); $perl->add_match_table("PosixPrint", Description => '[- 0-9A-Za-z!"#$%&\'()*+,./:;<=>?@[\\\]^_`{|}~]', @@ -13837,18 +13817,16 @@ sub compile_perl() { Initialize => $ASCII & $XPosixPunct, ); - my $Digit = $perl->add_match_table('Digit', + my $Digit = $perl->add_match_table('Digit', Full_Name => 'XPosixDigit', Description => '[0-9] + all other decimal digits'); $Digit->set_equivalent_to($gc->table('Decimal_Number'), Related => 1); - $Digit->add_alias('XPosixDigit'); my $PosixDigit = $perl->add_match_table("PosixDigit", Description => '[0-9]', Initialize => $Digit & $ASCII, ); # Hex_Digit was not present in first release - my $Xdigit = $perl->add_match_table('XDigit'); - $Xdigit->add_alias('XPosixXDigit'); + my $Xdigit = $perl->add_match_table('XDigit', Full_Name => 'XPosixXDigit'); my $Hex = property_ref('Hex_Digit'); if (defined $Hex && ! $Hex->is_empty) { $Xdigit->set_equivalent_to($Hex->table('Y'), Related => 1); @@ -17289,8 +17267,6 @@ sub write_all_tables() { # Similarly, we create for Unicode::UCD a list of # property-value aliases. - my $property_full_name = $property->full_name; - # Look at each table in the property... foreach my $table ($property->tables) { my @values_list; @@ -17329,7 +17305,7 @@ sub write_all_tables() { } # To save memory, unlike the similar list for property - # aliases above, only the standard forms hve the list. + # aliases above, only the standard forms have the list. # This forces an extra step of converting from input # name to standard name, but the savings are # considerable. (There is only marginal savings if we diff --git a/pod/perldelta.pod b/pod/perldelta.pod index d949107..e815790 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -172,9 +172,26 @@ L<Benchmark> has been upgraded from version 1.19 to 1.20. =item * L<Unicode::UCD> has been upgraded from version 0.60 to 0.61. + +=over 4 + +=item * + A new function L<property_values()|Unicode::UCD/prop_values()> has been added to return a given property's possible values. +=item * + +A bug has been fixed so that L<propaliases()|Unicode::UCD/prop_aliases()> +returns the correct short and long names for the Perl extensions where +it was incorrect. + +=item * + +This module now works on EBCDIC platforms. + +=back + =back =head2 Removed Modules and Pragmata -- Perl5 Master Repository
