diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/_charnames.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/_charnames.pm | 110 |
1 files changed, 71 insertions, 39 deletions
diff --git a/Master/tlpkg/tlperl/lib/_charnames.pm b/Master/tlpkg/tlperl/lib/_charnames.pm index c6169d16f86..b38028d24a7 100644 --- a/Master/tlpkg/tlperl/lib/_charnames.pm +++ b/Master/tlpkg/tlperl/lib/_charnames.pm @@ -6,7 +6,7 @@ package _charnames; use strict; use warnings; -our $VERSION = '1.45'; +our $VERSION = '1.48'; use unicore::Name; # mktables-generated algorithmically-defined names use bytes (); # for $bytes::hint_bits @@ -21,22 +21,22 @@ $Carp::Internal{ (__PACKAGE__) } = 1; # # The official names with their code points are stored in a table in # lib/unicore/Name.pl which is read in as a large string (almost 3/4 Mb in -# Unicode 6.0). Each code point/name combination is separated by a \n in the -# string. (Some of the CJK and the Hangul syllable names are instead -# determined algorithmically via subroutines stored instead in -# lib/unicore/Name.pm). Because of the large size of this table, it isn't -# converted into hashes for faster lookup. +# Unicode 6.0). Each code point sequence appears on a line by itself, with +# its corresponding name occupying the next line in the string. (Some of the +# CJK and the Hangul syllable names are instead determined algorithmically via +# subroutines stored instead in lib/unicore/Name.pm). Because of the large +# size of this table, it isn't converted into hashes for faster lookup. # # But, user defined aliases are stored in their own hashes, as are Perl # extensions to the official names. These are checked first before looking at # the official table. # # Basically, the table is grepped for the input code point (viacode()) or -# name (the other functions), and the corresponding value on the same line is -# returned. The grepping is done by turning the input into a regular -# expression. Thus, the same table does double duty, used by both name and -# code point lookup. (If we were to have hashes, we would need two, one for -# each lookup direction.) +# name (the other functions), and the corresponding value on the next or +# previous line is returned. The grepping is done by turning the input into a +# regular expression. Thus, the same table does double duty, used by both +# name and code point lookup. (If we were to have hashes, we would need two, +# one for each lookup direction.) # # For loose name matching, the logical thing would be to have a table # with all the ignorable characters squeezed out, and then grep it with the @@ -48,9 +48,9 @@ $Carp::Internal{ (__PACKAGE__) } = 1; # regular expression of the input name is modified to have optional spaces and # dashes between characters. For example, in strict matching, the regular # expression would be: -# qr/\tDIGIT ONE$/m +# qr/^DIGIT ONE$/m # Under loose matching, the blank would be squeezed out, and the re would be: -# qr/\tD[- ]?I[- ]?G[- ]?I[- ]?T[- ]?O[- ]?N[- ]?E$/m +# qr/^D[- ]?I[- ]?G[- ]?I[- ]?T[- ]?O[- ]?N[- ]?E$/m # which matches a blank or dash between any characters in the official table. # # This is also how script lookup is done. Basically the re looks like @@ -59,7 +59,7 @@ $Carp::Internal{ (__PACKAGE__) } = 1; # The hashes are stored as utf8 strings. This makes it easier to deal with # sequences. I (khw) also tried making Name.pl utf8, but it slowed things -# down by a factor of 7. I then tried making Name.pl store the ut8 +# down by a factor of 7. I then tried making Name.pl store the utf8 # equivalents but not calling them utf8. That led to similar speed as leaving # it alone, but since that is harder for a human to parse, I left it as-is. @@ -140,6 +140,14 @@ sub carp require Carp; goto &Carp::carp; } # carp +sub populate_txt() +{ + return if $txt; + + $txt = do "unicore/Name.pl"; + Internals::SvREADONLY($txt, 1); +} + sub alias (@) # Set up a single alias { my @errors; @@ -263,8 +271,9 @@ my %dummy_H = ( ); -sub lookup_name ($$$) { - my ($name, $wants_ord, $runtime) = @_; +sub lookup_name ($$$;$) { + my ($name, $wants_ord, $runtime, $regex_loose) = @_; + $regex_loose //= 0; # Lookup the name or sequence $name in the tables. If $wants_ord is false, # returns the string equivalent of $name; if true, returns the ordinal value @@ -281,7 +290,7 @@ sub lookup_name ($$$) { my $result; # The string result my $save_input; - if ($runtime) { + if ($runtime && ! $regex_loose) { my $hints_ref = (caller($runtime))[10]; @@ -307,16 +316,16 @@ sub lookup_name ($$$) { $^H{charnames_short} = $hints_ref->{charnames_short}; } - my $loose = $^H{charnames_loose}; + my $loose = $regex_loose || $^H{charnames_loose}; my $lookup_name; # Input name suitably modified for grepping for in the # table # User alias should be checked first or else can't override ours, and if we # were to add any, could conflict with theirs. - if (exists $^H{charnames_ord_aliases}{$name}) { + if (! $regex_loose && exists $^H{charnames_ord_aliases}{$name}) { $result = $^H{charnames_ord_aliases}{$name}; } - elsif (exists $^H{charnames_name_aliases}{$name}) { + elsif (! $regex_loose && exists $^H{charnames_name_aliases}{$name}) { $name = $^H{charnames_name_aliases}{$name}; $save_input = $lookup_name = $name; # Cache the result for any error # message @@ -403,11 +412,11 @@ sub lookup_name ($$$) { my $cache_ref; ## Suck in the code/name list as a big string. - ## Lines look like: - ## "00052\tLATIN CAPITAL LETTER R\n" + ## Entries look like: + ## "00052\nLATIN CAPITAL LETTER R\n\n" # or - # "0052 0303\tLATIN CAPITAL LETTER R WITH TILDE\n" - $txt = do "unicore/Name.pl" unless $txt; + # "0052 0303\nLATIN CAPITAL LETTER R WITH TILDE\n\n" + populate_txt() unless $txt; ## @off will hold the index into the code/name string of the start and ## end of the name as we find it. @@ -422,7 +431,7 @@ sub lookup_name ($$$) { # the other way around slows down finding these immensely. # Algorithmically determinables are not placed in the cache because # that uses up memory, and finding these again is fast. - if (($loose || $^H{charnames_full}) + if ( ($loose || $^H{charnames_full}) && (defined (my $ord = charnames::name_to_code_point_special($lookup_name, $loose)))) { $result = chr $ord; @@ -460,10 +469,14 @@ sub lookup_name ($$$) { # Do the lookup in the full table if asked for, and if succeeds # save the offsets and set where to cache the result. - if (($loose || $^H{charnames_full}) && $txt =~ /\t$lookup_name$/m) { - @off = ($-[0] + 1, $+[0]); # The 1 is for the tab + if (($loose || $^H{charnames_full}) && $txt =~ /^$lookup_name$/m) { + @off = ($-[0], $+[0]); $cache_ref = ($loose) ? \%loose_names_cache : \%full_names_cache; } + elsif ($regex_loose) { + # Currently don't allow :short when this is set + return; + } else { # Here, didn't look for, or didn't find the name. @@ -501,18 +514,18 @@ sub lookup_name ($$$) { my $case = $name_has_uppercase ? "CAPITAL" : "SMALL"; return if (! $scripts_trie || $txt !~ - /\t (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U$lookup_name $/xm); + /^ (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U$lookup_name $/xm); # Here have found the input name in the table. - @off = ($-[0] + 1, $+[0]); # The 1 is for the tab + @off = ($-[0], $+[0]); } # Here, the input name has been found; we haven't set up the output, # but we know where in the string # the name starts. The string is set up so that for single characters - # (and not named sequences), the name is preceded immediately by a - # tab and 5 hex digits for its code, with a \n before those. Named - # sequences won't have the 7th preceding character be a \n. + # (and not named sequences), the name is on a line by itself, and the + # previous line contains precisely 5 hex digits for its code point. + # Named sequences won't have the 7th preceding character be a \n. # (Actually, for the very first entry in the table this isn't strictly # true: subtracting 7 will yield -1, and the substr below will # therefore yield the very last character in the table, which should @@ -572,9 +585,11 @@ sub lookup_name ($$$) { # Here, wants string output. If utf8 is acceptable, just return what # we've got; otherwise attempt to convert it to non-utf8 and return that. - my $in_bytes = ($runtime) - ? (caller $runtime)[8] & $bytes::hint_bits - : $^H & $bytes::hint_bits; + my $in_bytes = ! $regex_loose # \p{name=} doesn't currently care if + # in bytes or not + && (($runtime) + ? (caller $runtime)[8] & $bytes::hint_bits + : $^H & $bytes::hint_bits); return $result if (! $in_bytes || utf8::downgrade($result, 1)) # The 1 arg # means don't die on failure } @@ -617,6 +632,23 @@ sub charnames { return lookup_name($_[0], 0, 0); } +sub _loose_regcomp_lookup { + # For use only by regcomp.c to compile \p{name=...} + # khw thinks it best to not do :short matching, and only official names. + # But that is only a guess, and if demand warrants, could be changed + return lookup_name($_[0], 0, 1, + 1 # Always use :loose matching + ); +} + +sub _get_names_info { + # For use only by regcomp.c to compile \p{name=/.../} + populate_txt() unless $txt; + + + return ( \$txt, \@charnames::code_points_ending_in_code_point ); +} + sub import { shift; ## ignore class name @@ -679,10 +711,10 @@ sub import ## see if at least we can find one letter from each script. ## if (warnings::enabled('utf8') && @scripts) { - $txt = do "unicore/Name.pl" unless $txt; + populate_txt() unless $txt; for my $script (@scripts) { - if (not $txt =~ m/\t$script (?:CAPITAL |SMALL )?LETTER /) { + if (not $txt =~ m/^$script (?:CAPITAL |SMALL )?LETTER /m) { warnings::warn('utf8', "No such script: '$script'"); $script = quotemeta $script; # Escape it, for use in the re. } @@ -757,7 +789,7 @@ sub viacode { # If the code point is above the max in the table, there's no point # looking through it. Checking the length first is slightly faster if (length($hex) <= 5 || CORE::hex($hex) <= 0x10FFFF) { - $txt = do "unicore/Name.pl" unless $txt; + populate_txt() unless $txt; # See if the name is algorithmically determinable. my $algorithmic = charnames::code_point_to_name_special(CORE::hex $hex); @@ -769,7 +801,7 @@ sub viacode { # Return the official name, if exists. It's unclear to me (khw) at # this juncture if it is better to return a user-defined override, so # leaving it as is for now. - if ($txt =~ m/^$hex\t/m) { + if ($txt =~ m/^$hex\n/m) { # The name starts with the next character and goes up to the # next new-line. Using capturing parentheses above instead of |