diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Unicode/UCD.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Unicode/UCD.pm | 405 |
1 files changed, 306 insertions, 99 deletions
diff --git a/Master/tlpkg/tlperl/lib/Unicode/UCD.pm b/Master/tlpkg/tlperl/lib/Unicode/UCD.pm index 724fb62785b..9c3dd7c7105 100644 --- a/Master/tlpkg/tlperl/lib/Unicode/UCD.pm +++ b/Master/tlpkg/tlperl/lib/Unicode/UCD.pm @@ -4,11 +4,8 @@ use strict; use warnings; no warnings 'surrogate'; # surrogates can be inputs to this use charnames (); -use Unicode::Normalize qw(getCombinClass NFD); -our $VERSION = '0.43'; - -use Storable qw(dclone); +our $VERSION = '0.51'; require Exporter; @@ -20,7 +17,7 @@ our @EXPORT_OK = qw(charinfo charinrange general_categories bidi_types compexcl - casefold casespec + casefold all_casefolds casespec namedseq num prop_aliases @@ -44,6 +41,9 @@ Unicode::UCD - Unicode character database use Unicode::UCD 'casefold'; my $casefold = casefold(0xFB00); + use Unicode::UCD 'all_casefolds'; + my $all_casefolds_ref = all_casefolds(); + use Unicode::UCD 'casespec'; my $casespec = casespec(0xFB00); @@ -104,8 +104,16 @@ a decimal or a hexadecimal scalar designating a Unicode code point, or C<U+> followed by hexadecimals designating a Unicode code point. In other words, if you want a code point to be interpreted as a hexadecimal number, you must prefix it with either C<0x> or C<U+>, because a string like e.g. C<123> will be -interpreted as a decimal code point. Note that the largest code point in -Unicode is U+10FFFF. +interpreted as a decimal code point. + +Examples: + + 223 # Decimal 223 + 0223 # Hexadecimal 223 (= 547 decimal) + 0xDF # Hexadecimal DF (= 223 decimal + U+DF # Hexadecimal DF + +Note that the largest code point in Unicode is U+10FFFF. =cut @@ -114,6 +122,7 @@ my $VERSIONFH; my $CASEFOLDFH; my $CASESPECFH; my $NAMEDSEQFH; +my $v_unicode_version; # v-string. sub openunicode { my ($rfh, @path) = @_; @@ -132,6 +141,35 @@ sub openunicode { return $f; } +sub _dclone ($) { # Use Storable::dclone if available; otherwise emulate it. + + use if defined &DynaLoader::boot_DynaLoader, Storable => qw(dclone); + + return dclone(shift) if defined &dclone; + + my $arg = shift; + my $type = ref $arg; + return $arg unless $type; # No deep cloning needed for scalars + + if ($type eq 'ARRAY') { + my @return; + foreach my $element (@$arg) { + push @return, &_dclone($element); + } + return \@return; + } + elsif ($type eq 'HASH') { + my %return; + foreach my $key (keys %$arg) { + $return{$key} = &_dclone($arg->{$key}); + } + return \%return; + } + else { + croak "_dclone can't handle " . $type; + } +} + =head2 B<charinfo()> use Unicode::UCD 'charinfo'; @@ -303,6 +341,7 @@ my %SIMPLE_LOWER; my %SIMPLE_TITLE; my %SIMPLE_UPPER; my %UNICODE_1_NAMES; +my %ISO_COMMENT; sub charinfo { @@ -315,6 +354,9 @@ sub charinfo { use feature 'unicode_strings'; + # Will fail if called under minitest + use if defined &DynaLoader::boot_DynaLoader, "Unicode::Normalize" => qw(getCombinClass NFD); + my $arg = shift; my $code = _getcode($arg); croak __PACKAGE__, "::charinfo: unknown code '$arg'" unless defined $code; @@ -353,7 +395,8 @@ sub charinfo { # Having no decomposition implies an empty field; otherwise, all but # "Canonical" imply a compatible decomposition, and the type is prefixed # to that, as it is in UnicodeData.txt - if ($char =~ /\p{Block=Hangul_Syllables}/) { + UnicodeVersion() unless defined $v_unicode_version; + if ($v_unicode_version ge v2.0.0 && $char =~ /\p{Block=Hangul_Syllables}/) { # The code points of the decomposition are output in standard Unicode # hex format, separated by blanks. $prop{'decomposition'} = join " ", map { sprintf("%04X", $_)} @@ -400,9 +443,16 @@ sub charinfo { %UNICODE_1_NAMES =_read_table("To/Na1.pl", "use_hash") unless %UNICODE_1_NAMES; $prop{'unicode10'} = $UNICODE_1_NAMES{$code} // ""; - # This is true starting in 6.0, but, num() also requires 6.0, so - # don't need to test for version again here. - $prop{'comment'} = ""; + UnicodeVersion() unless defined $v_unicode_version; + if ($v_unicode_version ge v6.0.0) { + $prop{'comment'} = ""; + } + else { + %ISO_COMMENT = _read_table("To/Isc.pl", "use_hash") unless %ISO_COMMENT; + $prop{'comment'} = (defined $ISO_COMMENT{$code}) + ? $ISO_COMMENT{$code} + : ""; + } %SIMPLE_UPPER = _read_table("To/Uc.pl", "use_hash") unless %SIMPLE_UPPER; $prop{'upper'} = (defined $SIMPLE_UPPER{$code}) @@ -536,7 +586,8 @@ With a L</code point argument> charblock() returns the I<block> the code point belongs to, e.g. C<Basic Latin>. The old-style block name is returned (see L</Old-style versus new-style block names>). If the code point is unassigned, this returns the block it would belong to if -it were assigned. +it were assigned. (If the Unicode version being used is so early as to not +have blocks, all code points are considered to be in C<No_Block>.) See also L</Blocks versus Scripts>. @@ -562,7 +613,13 @@ sub _charblocks { # Can't read from the mktables table because it loses the hyphens in the # original. unless (@BLOCKS) { - if (openunicode(\$BLOCKSFH, "Blocks.txt")) { + UnicodeVersion() unless defined $v_unicode_version; + if ($v_unicode_version lt v2.0.0) { + my $subrange = [ 0, 0x10FFFF, 'No_Block' ]; + push @BLOCKS, $subrange; + push @{$BLOCKS{'No_Block'}}, $subrange; + } + elsif (openunicode(\$BLOCKSFH, "Blocks.txt")) { local $_; local $/ = "\n"; while (<$BLOCKSFH>) { @@ -591,7 +648,7 @@ sub charblock { return 'No_Block'; } elsif (exists $BLOCKS{$arg}) { - return dclone $BLOCKS{$arg}; + return _dclone $BLOCKS{$arg}; } } @@ -607,7 +664,8 @@ sub charblock { With a L</code point argument> charscript() returns the I<script> the code point belongs to, e.g. C<Latin>, C<Greek>, C<Han>. -If the code point is unassigned, it returns C<"Unknown">. +If the code point is unassigned or the Unicode version being used is so early +that it doesn't have scripts, this function returns C<"Unknown">. If supplied with an argument that can't be a code point, charscript() tries to do the opposite and interpret the argument as a script name. The @@ -624,7 +682,15 @@ my @SCRIPTS; my %SCRIPTS; sub _charscripts { - @SCRIPTS =_read_table("To/Sc.pl") unless @SCRIPTS; + unless (@SCRIPTS) { + UnicodeVersion() unless defined $v_unicode_version; + if ($v_unicode_version lt v3.1.0) { + push @SCRIPTS, [ 0, 0x10FFFF, 'Unknown' ]; + } + else { + @SCRIPTS =_read_table("To/Sc.pl"); + } + } foreach my $entry (@SCRIPTS) { $entry->[2] =~ s/(_\w)/\L$1/g; # Preserve old-style casing push @{$SCRIPTS{$entry->[2]}}, $entry; @@ -643,7 +709,7 @@ sub charscript { return $result if defined $result; return $utf8::SwashInfo{'ToSc'}{'missing'}; } elsif (exists $SCRIPTS{$arg}) { - return dclone $SCRIPTS{$arg}; + return _dclone $SCRIPTS{$arg}; } return; @@ -670,7 +736,7 @@ See also L</Blocks versus Scripts>. sub charblocks { _charblocks() unless %BLOCKS; - return dclone \%BLOCKS; + return _dclone \%BLOCKS; } =head2 B<charscripts()> @@ -692,7 +758,7 @@ See also L</Blocks versus Scripts>. sub charscripts { _charscripts() unless %SCRIPTS; - return dclone \%SCRIPTS; + return _dclone \%SCRIPTS; } =head2 B<charinrange()> @@ -752,7 +818,7 @@ my %GENERAL_CATEGORIES = ); sub general_categories { - return dclone \%GENERAL_CATEGORIES; + return _dclone \%GENERAL_CATEGORIES; } =head2 B<general_categories()> @@ -820,7 +886,7 @@ the bidi type name. =cut sub bidi_types { - return dclone \%BIDI_TYPES; + return _dclone \%BIDI_TYPES; } =head2 B<compexcl()> @@ -829,7 +895,9 @@ sub bidi_types { my $compexcl = compexcl(0x09dc); -This routine is included for backwards compatibility, but as of Perl 5.12, for +This routine returns C<undef> if the Unicode version being used is so early +that it doesn't have this property. It is included for backwards +compatibility, but as of Perl 5.12 and more modern Unicode versions, for most purposes it is probably more convenient to use one of the following instead: @@ -864,6 +932,9 @@ sub compexcl { croak __PACKAGE__, "::compexcl: unknown code '$arg'" unless defined $code; + UnicodeVersion() unless defined $v_unicode_version; + return if $v_unicode_version lt v3.0.0; + no warnings "non_unicode"; # So works on non-Unicode code points return chr($code) =~ /\p{Composition_Exclusion}/; } @@ -943,12 +1014,12 @@ dotless lowercase i: =over -=item B<*> If you use this C<I> mapping +=item Z<>B<*> If you use this C<I> mapping the result is case-insensitive, but dotless and dotted I's are not distinguished -=item B<*> If you exclude this C<I> mapping +=item Z<>B<*> If you exclude this C<I> mapping the result is not fully case-insensitive, but dotless and dotted I's are distinguished @@ -997,54 +1068,88 @@ L<http://www.unicode.org/unicode/reports/tr21> my %CASEFOLD; sub _casefold { - unless (%CASEFOLD) { - if (openunicode(\$CASEFOLDFH, "CaseFolding.txt")) { - local $_; - local $/ = "\n"; - while (<$CASEFOLDFH>) { - if (/^([0-9A-F]+); ([CFIST]); ([0-9A-F]+(?: [0-9A-F]+)*);/) { - my $code = hex($1); - $CASEFOLD{$code}{'code'} = $1; - $CASEFOLD{$code}{'turkic'} = "" unless - defined $CASEFOLD{$code}{'turkic'}; - if ($2 eq 'C' || $2 eq 'I') { # 'I' is only on 3.1 and - # earlier Unicodes - # Both entries there (I - # only checked 3.1) are - # the same as C, and - # there are no other - # entries for those - # codepoints, so treat - # as if C, but override - # the turkic one for - # 'I'. - $CASEFOLD{$code}{'status'} = $2; - $CASEFOLD{$code}{'full'} = $CASEFOLD{$code}{'simple'} = - $CASEFOLD{$code}{'mapping'} = $3; - $CASEFOLD{$code}{'turkic'} = $3 if $2 eq 'I'; - } elsif ($2 eq 'F') { - $CASEFOLD{$code}{'full'} = $3; - unless (defined $CASEFOLD{$code}{'simple'}) { - $CASEFOLD{$code}{'simple'} = ""; - $CASEFOLD{$code}{'mapping'} = $3; - $CASEFOLD{$code}{'status'} = $2; - } - } elsif ($2 eq 'S') { + unless (%CASEFOLD) { # Populate the hash + my ($full_invlist_ref, $full_invmap_ref, undef, $default) + = prop_invmap('Case_Folding'); + + # Use the recipe given in the prop_invmap() pod to convert the + # inversion map into the hash. + for my $i (0 .. @$full_invlist_ref - 1 - 1) { + next if $full_invmap_ref->[$i] == $default; + my $adjust = -1; + for my $j ($full_invlist_ref->[$i] .. $full_invlist_ref->[$i+1] -1) { + $adjust++; + if (! ref $full_invmap_ref->[$i]) { + + # This is a single character mapping + $CASEFOLD{$j}{'status'} = 'C'; + $CASEFOLD{$j}{'simple'} + = $CASEFOLD{$j}{'full'} + = $CASEFOLD{$j}{'mapping'} + = sprintf("%04X", $full_invmap_ref->[$i] + $adjust); + $CASEFOLD{$j}{'code'} = sprintf("%04X", $j); + $CASEFOLD{$j}{'turkic'} = ""; + } + else { # prop_invmap ensures that $adjust is 0 for a ref + $CASEFOLD{$j}{'status'} = 'F'; + $CASEFOLD{$j}{'full'} + = $CASEFOLD{$j}{'mapping'} + = join " ", map { sprintf "%04X", $_ } + @{$full_invmap_ref->[$i]}; + $CASEFOLD{$j}{'simple'} = ""; + $CASEFOLD{$j}{'code'} = sprintf("%04X", $j); + $CASEFOLD{$j}{'turkic'} = ""; + } + } + } + # We have filled in the full mappings above, assuming there were no + # simple ones for the ones with multi-character maps. Now, we find + # and fix the cases where that assumption was false. + (my ($simple_invlist_ref, $simple_invmap_ref, undef), $default) + = prop_invmap('Simple_Case_Folding'); + for my $i (0 .. @$simple_invlist_ref - 1 - 1) { + next if $simple_invmap_ref->[$i] == $default; + my $adjust = -1; + for my $j ($simple_invlist_ref->[$i] + .. $simple_invlist_ref->[$i+1] -1) + { + $adjust++; + next if $CASEFOLD{$j}{'status'} eq 'C'; + $CASEFOLD{$j}{'status'} = 'S'; + $CASEFOLD{$j}{'simple'} + = $CASEFOLD{$j}{'mapping'} + = sprintf("%04X", $simple_invmap_ref->[$i] + $adjust); + $CASEFOLD{$j}{'code'} = sprintf("%04X", $j); + $CASEFOLD{$j}{'turkic'} = ""; + } + } - # There can't be a simple without a full, and simple - # overrides all but full + # We hard-code in the turkish rules + UnicodeVersion() unless defined $v_unicode_version; + if ($v_unicode_version ge v3.2.0) { - $CASEFOLD{$code}{'simple'} = $3; - $CASEFOLD{$code}{'mapping'} = $3; - $CASEFOLD{$code}{'status'} = $2; - } elsif ($2 eq 'T') { - $CASEFOLD{$code}{'turkic'} = $3; - } # else can't happen because only [CIFST] are possible - } - } - close($CASEFOLDFH); - } + # These two code points should already have regular entries, so + # just fill in the turkish fields + $CASEFOLD{ord('I')}{'turkic'} = '0131'; + $CASEFOLD{0x130}{'turkic'} = sprintf "%04X", ord('i'); + } + elsif ($v_unicode_version ge v3.1.0) { + + # These two code points don't have entries otherwise. + $CASEFOLD{0x130}{'code'} = '0130'; + $CASEFOLD{0x131}{'code'} = '0131'; + $CASEFOLD{0x130}{'status'} = $CASEFOLD{0x131}{'status'} = 'I'; + $CASEFOLD{0x130}{'turkic'} + = $CASEFOLD{0x130}{'mapping'} + = $CASEFOLD{0x130}{'full'} + = $CASEFOLD{0x130}{'simple'} + = $CASEFOLD{0x131}{'turkic'} + = $CASEFOLD{0x131}{'mapping'} + = $CASEFOLD{0x131}{'full'} + = $CASEFOLD{0x131}{'simple'} + = sprintf "%04X", ord('i'); + } } } @@ -1059,6 +1164,55 @@ sub casefold { return $CASEFOLD{$code}; } +=head2 B<all_casefolds()> + + + use Unicode::UCD 'all_casefolds'; + + my $all_folds_ref = all_casefolds(); + foreach my $char_with_casefold (sort { $a <=> $b } + keys %$all_folds_ref) + { + printf "%04X:", $char_with_casefold; + my $casefold = $all_folds_ref->{$char_with_casefold}; + + # Get folds for $char_with_casefold + + my @full_fold_hex = split / /, $casefold->{'full'}; + my $full_fold_string = + join "", map {chr(hex($_))} @full_fold_hex; + print " full=", join " ", @full_fold_hex; + my @turkic_fold_hex = + split / /, ($casefold->{'turkic'} ne "") + ? $casefold->{'turkic'} + : $casefold->{'full'}; + my $turkic_fold_string = + join "", map {chr(hex($_))} @turkic_fold_hex; + print "; turkic=", join " ", @turkic_fold_hex; + if (defined $casefold && $casefold->{'simple'} ne "") { + my $simple_fold_hex = $casefold->{'simple'}; + my $simple_fold_string = chr(hex($simple_fold_hex)); + print "; simple=$simple_fold_hex"; + } + print "\n"; + } + +This returns all the case foldings in the current version of Unicode in the +form of a reference to a hash. Each key to the hash is the decimal +representation of a Unicode character that has a casefold to other than +itself. The casefold of a semi-colon is itself, so it isn't in the hash; +likewise for a lowercase "a", but there is an entry for a capital "A". The +hash value for each key is another hash, identical to what is returned by +L</casefold()> if called with that code point as its argument. So the value +C<< all_casefolds()->{ord("A")}' >> is equivalent to C<casefold(ord("A"))>; + +=cut + +sub all_casefolds () { + _casefold() unless %CASEFOLD; + return _dclone \%CASEFOLD; +} + =head2 B<casespec()> use Unicode::UCD 'casespec'; @@ -1161,15 +1315,25 @@ my %CASESPEC; sub _casespec { unless (%CASESPEC) { - if (openunicode(\$CASESPECFH, "SpecialCasing.txt")) { + UnicodeVersion() unless defined $v_unicode_version; + if ($v_unicode_version lt v2.1.8) { + %CASESPEC = {}; + } + elsif (openunicode(\$CASESPECFH, "SpecialCasing.txt")) { local $_; local $/ = "\n"; while (<$CASESPECFH>) { if (/^([0-9A-F]+); ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; ([0-9A-F]+(?: [0-9A-F]+)*)?; (\w+(?: \w+)*)?/) { + my ($hexcode, $lower, $title, $upper, $condition) = ($1, $2, $3, $4, $5); my $code = hex($hexcode); - if (exists $CASESPEC{$code}) { + + # In 2.1.8, there were duplicate entries; ignore all but + # the first one -- there were no conditions in the file + # anyway. + if (exists $CASESPEC{$code} && $v_unicode_version ne v2.1.8) + { if (exists $CASESPEC{$code}->{code}) { my ($oldlower, $oldtitle, @@ -1222,7 +1386,7 @@ sub casespec { _casespec() unless %CASESPEC; - return ref $CASESPEC{$code} ? dclone $CASESPEC{$code} : $CASESPEC{$code}; + return ref $CASESPEC{$code} ? _dclone $CASESPEC{$code} : $CASESPEC{$code}; } =head2 B<namedseq()> @@ -1307,16 +1471,6 @@ sub namedseq { my %NUMERIC; sub _numeric { - - # Unicode 6.0 instituted the rule that only digits in a consecutive - # block of 10 would be considered decimal digits. Before that, the only - # problematic code point that I'm (khw) aware of is U+019DA, NEW TAI LUE - # THAM DIGIT ONE, which is an alternate form of U+019D1, NEW TAI LUE DIGIT - # ONE. The code could be modified to handle that, but not bothering, as - # in TUS 6.0, U+19DA was changed to Nt=Di. - if ((pack "C*", split /\./, UnicodeVersion()) lt 6.0.0) { - croak __PACKAGE__, "::num requires Unicode 6.0 or greater" - } my @numbers = _read_table("To/Nv.pl"); foreach my $entry (@numbers) { my ($start, $end, $value) = @$entry; @@ -1427,14 +1581,43 @@ sub num { return if $string =~ /\D/; my $first_ord = ord(substr($string, 0, 1)); my $value = $NUMERIC{$first_ord}; + + # To be a valid decimal number, it should be in a block of 10 consecutive + # characters, whose values are 0, 1, 2, ... 9. Therefore this digit's + # value is its offset in that block from the character that means zero. my $zero_ord = $first_ord - $value; + # Unicode 6.0 instituted the rule that only digits in a consecutive + # block of 10 would be considered decimal digits. If this is an earlier + # release, we verify that this first character is a member of such a + # block. That is, that the block of characters surrounding this one + # consists of all \d characters whose numeric values are the expected + # ones. + UnicodeVersion() unless defined $v_unicode_version; + if ($v_unicode_version lt v6.0.0) { + for my $i (0 .. 9) { + my $ord = $zero_ord + $i; + return unless chr($ord) =~ /\d/; + my $numeric = $NUMERIC{$ord}; + return unless defined $numeric; + return unless $numeric == $i; + } + } + for my $i (1 .. $length -1) { + + # Here we know either by verifying, or by fact of the first character + # being a \d in Unicode 6.0 or later, that any character between the + # character that means 0, and 9 positions above it must be \d, and + # must have its value correspond to its offset from the zero. Any + # characters outside these 10 do not form a legal number for this + # function. my $ord = ord(substr($string, $i, 1)); my $digit = $ord - $zero_ord; return unless $digit >= 0 && $digit <= 9; $value = $value * 10 + $digit; } + return $value; } @@ -1676,7 +1859,7 @@ sub prop_aliases ($) { # The full name is in element 1. return $list_ref->[1] unless wantarray; - return @{dclone $list_ref}; + return @{_dclone $list_ref}; } =pod @@ -1815,7 +1998,7 @@ sub prop_value_aliases ($$) { # The full name is in element 1. return $list_ref->[1] unless wantarray; - return @{dclone $list_ref}; + return @{_dclone $list_ref}; } return $list_ref->[0] unless wantarray; @@ -1842,7 +2025,8 @@ by the input parameter string: prints: 0, 1114112 -An empty list is returned if the input is unknown; the number of elements in +If the input is unknown C<undef> is returned in scalar context; an empty-list +in list context. If the input is known, the number of elements in the list is returned if called in scalar context. L<perluniprops|perluniprops/Properties accessible through \p{} and \P{}> gives @@ -1952,8 +2136,12 @@ properties, and will return C<undef> if called with one of those. our %loose_defaults; our $MAX_UNICODE_CODEPOINT; -sub prop_invlist ($) { +sub prop_invlist ($;$) { my $prop = $_[0]; + + # Undocumented way to get at Perl internal properties + my $internal_ok = defined $_[1] && $_[1] eq '_perl_core_internal_ok'; + return if ! defined $prop; require "utf8_heavy.pl"; @@ -1970,7 +2158,7 @@ sub prop_invlist ($) { || ref $swash eq "" || $swash->{'BITS'} != 1 || $swash->{'USER_DEFINED'} - || $prop =~ /^\s*_/; + || (! $internal_ok && $prop =~ /^\s*_/); if ($swash->{'EXTRAS'}) { carp __PACKAGE__, "::prop_invlist: swash returned for $prop unexpectedly has EXTRAS magic"; @@ -2075,7 +2263,8 @@ sub prop_invlist ($) { sub _search_invlist { # Find the range in the inversion list which contains a code point; that - # is, find i such that l[i] <= code_point < l[i+1] + # is, find i such that l[i] <= code_point < l[i+1]. Returns undef if no + # such i. # If this is ever made public, could use to speed up .t specials. Would # need to use code point argument, as in other functions in this pm @@ -2085,7 +2274,10 @@ sub _search_invlist { # Verify non-neg numeric XXX my $max_element = @$list_ref - 1; - return if ! $max_element < 0; # Undef if list is empty. + + # Return undef if list is empty or requested item is before the first element. + return if $max_element < 0; + return if $code_point < $list_ref->[0]; # Short cut something at the far-end of the table. This also allows us to # refer to element [$i+1] without fear of being out-of-bounds in the loop @@ -2431,7 +2623,7 @@ means that all the elements of the map array are either rational numbers or the string C<"NaN">, meaning "Not a Number". A rational number is either an integer, or two integers separated by a solidus (C<"/">). The second integer represents the denominator of the division implied by the solidus, and is -actually always positive, so it is guaranteed not to be 0 and to not to be +actually always positive, so it is guaranteed not to be 0 and to not be signed. When the element is a plain integer (without the solidus), it may need to be adjusted to get the correct value by adding the offset, just as other C<"a"> properties. No adjustment is needed for @@ -2443,7 +2635,7 @@ can use something like this: my ($invlist_ref, $invmap_ref, $format) = prop_invmap($property); if ($format && $format eq "ar") { - map { $_ = eval $_ } @$invmap_ref; + map { $_ = eval $_ if $_ ne 'NaN' } @$map_ref; } Here's some entries from the output of the property "Nv", which has format @@ -2665,7 +2857,7 @@ RETRY: $prop = "age"; goto RETRY; } - elsif ($second_try =~ / ^ s ( cf | [ltu] c ) $ /x) { + elsif ($second_try =~ / ^ s ( cf | fc | [ltu] c ) $ /x) { # These properties use just the LIST part of the full mapping, # which includes the simple maps that are otherwise overridden by @@ -2674,7 +2866,11 @@ RETRY: $overrides = -1; # The full name is the simple name stripped of its initial 's' - $prop = $second_try =~ s/^s//r; + $prop = $1; + + # .. except for this case + $prop = 'cf' if $prop eq 'fc'; + goto RETRY; } elsif ($second_try eq "blk") { @@ -2733,7 +2929,7 @@ RETRY: my ($hex_code_point, $name) = split "\t", $line; # Weeds out all comments, blank lines, and named sequences - next if $hex_code_point =~ /\P{ASCII_HEX_DIGIT}/; + next if $hex_code_point =~ /[^[:xdigit:]]/a; my $code_point = hex $hex_code_point; @@ -2791,8 +2987,11 @@ RETRY: $decomps{'LIST'} = ""; # This property has one special range not in the file: for the - # hangul syllables - my $done_hangul = 0; # Have we done the hangul range. + # hangul syllables. But not in Unicode version 1. + UnicodeVersion() unless defined $v_unicode_version; + my $done_hangul = ($v_unicode_version lt v2.0.0) + ? 1 + : 0; # Have we done the hangul range ? foreach my $line (split "\n", $original) { my ($hex_lower, $hex_upper, $type_and_map) = split "\t", $line; my $code_point = hex $hex_lower; @@ -2822,6 +3021,12 @@ RETRY: : "<hangul syllable>"; } + if ($value =~ / / && $hex_upper ne "" && $hex_upper ne $hex_lower) { + $line = sprintf("%04X\t%s\t%s", hex($hex_lower) + 1, $hex_upper, $value); + $hex_upper = ""; + $redo = 1; + } + # And append this to our constructed LIST. $decomps{'LIST'} .= "$hex_lower\t$hex_upper\t$value\n"; @@ -2863,8 +3068,8 @@ RETRY: } else { - # These should all single-element ranges. - croak __PACKAGE__, "::prop_invmap: Not expecting a mapping with multiple code points in a multi-element range, $ranges[$i]" if $hex_end ne ""; + # These should all be single-element ranges. + croak __PACKAGE__, "::prop_invmap: Not expecting a mapping with multiple code points in a multi-element range, $ranges[$i]" if $hex_end ne "" && $hex_end ne $hex_begin; # Convert them to decimal, as that's what's expected. $list .= "$hex_begin\t\t" @@ -3334,6 +3539,7 @@ sub UnicodeVersion { croak __PACKAGE__, "::VERSION: strange version '$UNICODEVERSION'" unless $UNICODEVERSION =~ /^\d+(?:\.\d+)+$/; } + $v_unicode_version = pack "C*", split /\./, $UNICODEVERSION; return $UNICODEVERSION; } @@ -3342,7 +3548,8 @@ sub UnicodeVersion { The difference between a block and a script is that scripts are closer to the linguistic notion of a set of code points required to present languages, while block is more of an artifact of the Unicode code point -numbering and separation into blocks of (mostly) 256 code points. +numbering and separation into blocks of consecutive code points (so far the +size of a block is some multiple of 16, like 128 or 256). For example the Latin B<script> is spread over several B<blocks>, such as C<Basic Latin>, C<Latin 1 Supplement>, C<Latin Extended-A>, and |