| 1 | # !!!!!!! INTERNAL PERL USE ONLY !!!!!!! |
| 2 | # This helper module is for internal use by core Perl only. This module is |
| 3 | # subject to change or removal at any time without notice. Don't use it |
| 4 | # directly. Use the public <charnames> module instead. |
| 5 | |
| 6 | package _charnames; |
| 7 | use strict; |
| 8 | use warnings; |
| 9 | use File::Spec; |
| 10 | our $VERSION = '1.39'; |
| 11 | use unicore::Name; # mktables-generated algorithmically-defined names |
| 12 | |
| 13 | use bytes (); # for $bytes::hint_bits |
| 14 | use re "/aa"; # Everything in here should be ASCII |
| 15 | |
| 16 | $Carp::Internal{ (__PACKAGE__) } = 1; |
| 17 | |
| 18 | # Translate between Unicode character names and their code points. This is a |
| 19 | # submodule of package <charnames>, used to allow \N{...} to be autoloaded, |
| 20 | # but it was decided not to autoload the various functions in charnames; the |
| 21 | # splitting allows this behavior. |
| 22 | # |
| 23 | # The official names with their code points are stored in a table in |
| 24 | # lib/unicore/Name.pl which is read in as a large string (almost 3/4 Mb in |
| 25 | # Unicode 6.0). Each code point/name combination is separated by a \n in the |
| 26 | # string. (Some of the CJK and the Hangul syllable names are determined |
| 27 | # instead algorithmically via subroutines stored instead in |
| 28 | # lib/unicore/Name.pm). Because of the large size of this table, it isn't |
| 29 | # converted into hashes for faster lookup. |
| 30 | # |
| 31 | # But, user defined aliases are stored in their own hashes, as are Perl |
| 32 | # extensions to the official names. These are checked first before looking at |
| 33 | # the official table. |
| 34 | # |
| 35 | # Basically, the table is grepped for the input code point (viacode()) or |
| 36 | # name (the other functions), and the corresponding value on the same line is |
| 37 | # returned. The grepping is done by turning the input into a regular |
| 38 | # expression. Thus, the same table does double duty, used by both name and |
| 39 | # code point lookup. (If we were to have hashes, we would need two, one for |
| 40 | # each lookup direction.) |
| 41 | # |
| 42 | # For loose name matching, the logical thing would be to have a table |
| 43 | # with all the ignorable characters squeezed out, and then grep it with the |
| 44 | # similiarly-squeezed input name. (And this is in fact how the lookups are |
| 45 | # done with the small Perl extension hashes.) But since we need to be able to |
| 46 | # go from code point to official name, the original table would still need to |
| 47 | # exist. Due to the large size of the table, it was decided to not read |
| 48 | # another very large string into memory for a second table. Instead, the |
| 49 | # regular expression of the input name is modified to have optional spaces and |
| 50 | # dashes between characters. For example, in strict matching, the regular |
| 51 | # expression would be: |
| 52 | # qr/\tDIGIT ONE$/m |
| 53 | # Under loose matching, the blank would be squeezed out, and the re would be: |
| 54 | # qr/\tD[- ]?I[- ]?G[- ]?I[- ]?T[- ]?O[- ]?N[- ]?E$/m |
| 55 | # which matches a blank or dash between any characters in the official table. |
| 56 | # |
| 57 | # This is also how script lookup is done. Basically the re looks like |
| 58 | # qr/ (?:LATIN|GREEK|CYRILLIC) (?:SMALL )?LETTER $name/ |
| 59 | # where $name is the loose or strict regex for the remainder of the name. |
| 60 | |
| 61 | # The hashes are stored as utf8 strings. This makes it easier to deal with |
| 62 | # sequences. I (khw) also tried making Name.pl utf8, but it slowed things |
| 63 | # down by a factor of 7. I then tried making Name.pl store the ut8 |
| 64 | # equivalents but not calling them utf8. That led to similar speed as leaving |
| 65 | # it alone, but since that is harder for a human to parse, I left it as-is. |
| 66 | |
| 67 | my %system_aliases = ( |
| 68 | |
| 69 | 'SINGLE-SHIFT 2' => pack("U", utf8::unicode_to_native(0x8E)), |
| 70 | 'SINGLE-SHIFT 3' => pack("U", utf8::unicode_to_native(0x8F)), |
| 71 | 'PRIVATE USE 1' => pack("U", utf8::unicode_to_native(0x91)), |
| 72 | 'PRIVATE USE 2' => pack("U", utf8::unicode_to_native(0x92)), |
| 73 | ); |
| 74 | |
| 75 | # These are the aliases above that differ under :loose and :full matching |
| 76 | # because the :full versions have blanks or hyphens in them. |
| 77 | #my %loose_system_aliases = ( |
| 78 | #); |
| 79 | |
| 80 | #my %deprecated_aliases; |
| 81 | #$deprecated_aliases{'BELL'} = pack("U", utf8::unicode_to_native(0x07)) if $^V lt v5.17.0; |
| 82 | |
| 83 | #my %loose_deprecated_aliases = ( |
| 84 | #); |
| 85 | |
| 86 | # These are special cased in :loose matching, differing only in a medial |
| 87 | # hyphen |
| 88 | my $HANGUL_JUNGSEONG_O_E_utf8 = pack("U", 0x1180); |
| 89 | my $HANGUL_JUNGSEONG_OE_utf8 = pack("U", 0x116C); |
| 90 | |
| 91 | |
| 92 | my $txt; # The table of official character names |
| 93 | |
| 94 | my %full_names_cache; # Holds already-looked-up names, so don't have to |
| 95 | # re-look them up again. The previous versions of charnames had scoping |
| 96 | # bugs. For example if we use script A in one scope and find and cache |
| 97 | # what Z resolves to, we can't use that cache in a different scope that |
| 98 | # uses script B instead of A, as Z might be an entirely different letter |
| 99 | # there; or there might be different aliases in effect in different |
| 100 | # scopes, or :short may be in effect or not effect in different scopes, |
| 101 | # or various combinations thereof. This was solved in this version |
| 102 | # mostly by moving things to %^H. But some things couldn't be moved |
| 103 | # there. One of them was the cache of runtime looked-up names, in part |
| 104 | # because %^H is read-only at runtime. I (khw) don't know why the cache |
| 105 | # was run-time only in the previous versions: perhaps oversight; perhaps |
| 106 | # that compile time looking doesn't happen in a loop so didn't think it |
| 107 | # was worthwhile; perhaps not wanting to make the cache too large. But |
| 108 | # I decided to make it compile time as well; this could easily be |
| 109 | # changed. |
| 110 | # Anyway, this hash is not scoped, and is added to at runtime. It |
| 111 | # doesn't have scoping problems because the data in it is restricted to |
| 112 | # official names, which are always invariant, and we only set it and |
| 113 | # look at it at during :full lookups, so is unaffected by any other |
| 114 | # scoped options. I put this in to maintain parity with the older |
| 115 | # version. If desired, a %short_names cache could also be made, as well |
| 116 | # as one for each script, say in %script_names_cache, with each key |
| 117 | # being a hash for a script named in a 'use charnames' statement. I |
| 118 | # decided not to do that for now, just because it's added complication, |
| 119 | # and because I'm just trying to maintain parity, not extend it. |
| 120 | |
| 121 | # Like %full_names_cache, but for use when :loose is in effect. There needs |
| 122 | # to be two caches because :loose may not be in effect for a scope, and a |
| 123 | # loose name could inappropriately be returned when only exact matching is |
| 124 | # called for. |
| 125 | my %loose_names_cache; |
| 126 | |
| 127 | # Designed so that test decimal first, and then hex. Leading zeros |
| 128 | # imply non-decimal, as do non-[0-9] |
| 129 | my $decimal_qr = qr/^[1-9]\d*$/; |
| 130 | |
| 131 | # Returns the hex number in $1. |
| 132 | my $hex_qr = qr/^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/; |
| 133 | |
| 134 | sub croak |
| 135 | { |
| 136 | require Carp; goto &Carp::croak; |
| 137 | } # croak |
| 138 | |
| 139 | sub carp |
| 140 | { |
| 141 | require Carp; goto &Carp::carp; |
| 142 | } # carp |
| 143 | |
| 144 | sub alias (@) # Set up a single alias |
| 145 | { |
| 146 | my @errors; |
| 147 | |
| 148 | my $alias = ref $_[0] ? $_[0] : { @_ }; |
| 149 | foreach my $name (sort keys %$alias) { # Sort only because it helps having |
| 150 | # deterministic output for |
| 151 | # t/lib/charnames/alias |
| 152 | my $value = $alias->{$name}; |
| 153 | next unless defined $value; # Omit if screwed up. |
| 154 | |
| 155 | # Is slightly slower to just after this statement see if it is |
| 156 | # decimal, since we already know it is after having converted from |
| 157 | # hex, but makes the code easier to maintain, and is called |
| 158 | # infrequently, only at compile-time |
| 159 | if ($value !~ $decimal_qr && $value =~ $hex_qr) { |
| 160 | my $temp = CORE::hex $1; |
| 161 | $temp = utf8::unicode_to_native($temp) if $value =~ /^[Uu]\+/; |
| 162 | $value = $temp; |
| 163 | } |
| 164 | if ($value =~ $decimal_qr) { |
| 165 | no warnings qw(non_unicode surrogate nonchar); # Allow any of these |
| 166 | $^H{charnames_ord_aliases}{$name} = pack("U", $value); |
| 167 | |
| 168 | # Use a canonical form. |
| 169 | $^H{charnames_inverse_ords}{sprintf("%05X", $value)} = $name; |
| 170 | } |
| 171 | else { |
| 172 | # This regex needs to be sync'd with the code in toke.c that checks |
| 173 | # for the same thing |
| 174 | if ($name !~ / ^ |
| 175 | \p{_Perl_Charname_Begin} |
| 176 | \p{_Perl_Charname_Continue}* |
| 177 | $ /x) { |
| 178 | |
| 179 | push @errors, $name; |
| 180 | } |
| 181 | else { |
| 182 | $^H{charnames_name_aliases}{$name} = $value; |
| 183 | |
| 184 | if (warnings::enabled('deprecated')) { |
| 185 | if ($name =~ / ( .* \s ) ( \s* ) $ /x) { |
| 186 | carp "Trailing white-space in a charnames alias definition is deprecated; marked by <-- HERE in '$1 <-- HERE " . $2 . "'"; |
| 187 | } |
| 188 | |
| 189 | # Use '+' instead of '*' in this regex, because any trailing |
| 190 | # blanks have already been warned about. |
| 191 | if ($name =~ / ( .*? \s{2} ) ( .+ ) /x) { |
| 192 | carp "A sequence of multiple spaces in a charnames alias definition is deprecated; marked by <-- HERE in '$1 <-- HERE " . $2 . "'"; |
| 193 | } |
| 194 | } |
| 195 | } |
| 196 | } |
| 197 | } |
| 198 | |
| 199 | # We find and output all errors from this :alias definition, rather than |
| 200 | # failing on the first one, so fewer runs are needed to get it to compile |
| 201 | if (@errors) { |
| 202 | foreach my $name (@errors) { |
| 203 | my $ok = ""; |
| 204 | my $nbsp = chr utf8::unicode_to_native(0xa0); |
| 205 | $ok = $1 if $name =~ / ^ ( \p{Alpha} [-\p{XPosixWord} ():$nbsp]* ) /x; |
| 206 | my $first_bad = substr($name, length($ok), 1); |
| 207 | $name = "Invalid character in charnames alias definition; marked by <-- HERE in '$ok$first_bad<-- HERE " . substr($name, length($ok) + 1) . "'"; |
| 208 | } |
| 209 | croak join "\n", @errors; |
| 210 | } |
| 211 | |
| 212 | return; |
| 213 | } # alias |
| 214 | |
| 215 | sub not_legal_use_bytes_msg { |
| 216 | my ($name, $utf8) = @_; |
| 217 | my $return; |
| 218 | |
| 219 | if (length($utf8) == 1) { |
| 220 | $return = sprintf("Character 0x%04x with name '%s' is", ord $utf8, $name); |
| 221 | } else { |
| 222 | $return = sprintf("String with name '%s' (and ordinals %s) contains character(s)", $name, join(" ", map { sprintf "0x%04X", ord $_ } split(//, $utf8))); |
| 223 | } |
| 224 | return $return . " above 0xFF with 'use bytes' in effect"; |
| 225 | } |
| 226 | |
| 227 | sub alias_file ($) # Reads a file containing alias definitions |
| 228 | { |
| 229 | my ($arg, $file) = @_; |
| 230 | if (-f $arg && File::Spec->file_name_is_absolute ($arg)) { |
| 231 | $file = $arg; |
| 232 | } |
| 233 | elsif ($arg =~ m/ ^ \p{_Perl_IDStart} \p{_Perl_IDCont}* $/x) { |
| 234 | $file = "unicore/${arg}_alias.pl"; |
| 235 | } |
| 236 | else { |
| 237 | croak "Charnames alias file names can only have identifier characters"; |
| 238 | } |
| 239 | if (my @alias = do $file) { |
| 240 | @alias == 1 && !defined $alias[0] and |
| 241 | croak "$file cannot be used as alias file for charnames"; |
| 242 | @alias % 2 and |
| 243 | croak "$file did not return a (valid) list of alias pairs"; |
| 244 | alias (@alias); |
| 245 | return (1); |
| 246 | } |
| 247 | 0; |
| 248 | } # alias_file |
| 249 | |
| 250 | # For use when don't import anything. This structure must be kept in |
| 251 | # sync with the one that import() fills up. |
| 252 | my %dummy_H = ( |
| 253 | charnames_stringified_names => "", |
| 254 | charnames_stringified_ords => "", |
| 255 | charnames_scripts => "", |
| 256 | charnames_full => 1, |
| 257 | charnames_loose => 0, |
| 258 | charnames_short => 0, |
| 259 | ); |
| 260 | |
| 261 | |
| 262 | sub lookup_name ($$$) { |
| 263 | my ($name, $wants_ord, $runtime) = @_; |
| 264 | |
| 265 | # Lookup the name or sequence $name in the tables. If $wants_ord is false, |
| 266 | # returns the string equivalent of $name; if true, returns the ordinal value |
| 267 | # instead, but in this case $name must not be a sequence; otherwise undef is |
| 268 | # returned and a warning raised. $runtime is 0 if compiletime, otherwise |
| 269 | # gives the number of stack frames to go back to get the application caller |
| 270 | # info. |
| 271 | # If $name is not found, returns undef in runtime with no warning; and in |
| 272 | # compiletime, the Unicode replacement character, with a warning. |
| 273 | |
| 274 | # It looks first in the aliases, then in the large table of official Unicode |
| 275 | # names. |
| 276 | |
| 277 | my $utf8; # The string result |
| 278 | my $save_input; |
| 279 | |
| 280 | if ($runtime) { |
| 281 | |
| 282 | my $hints_ref = (caller($runtime))[10]; |
| 283 | |
| 284 | # If we didn't import anything (which happens with 'use charnames ()', |
| 285 | # substitute a dummy structure. |
| 286 | $hints_ref = \%dummy_H if ! defined $hints_ref |
| 287 | || (! defined $hints_ref->{charnames_full} |
| 288 | && ! defined $hints_ref->{charnames_loose}); |
| 289 | |
| 290 | # At runtime, but currently not at compile time, $^H gets |
| 291 | # stringified, so un-stringify back to the original data structures. |
| 292 | # These get thrown away by perl before the next invocation |
| 293 | # Also fill in the hash with the non-stringified data. |
| 294 | # N.B. New fields must be also added to %dummy_H |
| 295 | |
| 296 | %{$^H{charnames_name_aliases}} = split ',', |
| 297 | $hints_ref->{charnames_stringified_names}; |
| 298 | %{$^H{charnames_ord_aliases}} = split ',', |
| 299 | $hints_ref->{charnames_stringified_ords}; |
| 300 | $^H{charnames_scripts} = $hints_ref->{charnames_scripts}; |
| 301 | $^H{charnames_full} = $hints_ref->{charnames_full}; |
| 302 | $^H{charnames_loose} = $hints_ref->{charnames_loose}; |
| 303 | $^H{charnames_short} = $hints_ref->{charnames_short}; |
| 304 | } |
| 305 | |
| 306 | my $loose = $^H{charnames_loose}; |
| 307 | my $lookup_name; # Input name suitably modified for grepping for in the |
| 308 | # table |
| 309 | |
| 310 | # User alias should be checked first or else can't override ours, and if we |
| 311 | # were to add any, could conflict with theirs. |
| 312 | if (exists $^H{charnames_ord_aliases}{$name}) { |
| 313 | $utf8 = $^H{charnames_ord_aliases}{$name}; |
| 314 | } |
| 315 | elsif (exists $^H{charnames_name_aliases}{$name}) { |
| 316 | $name = $^H{charnames_name_aliases}{$name}; |
| 317 | $save_input = $lookup_name = $name; # Cache the result for any error |
| 318 | # message |
| 319 | # The aliases are documented to not match loosely, so change loose match |
| 320 | # into full. |
| 321 | if ($loose) { |
| 322 | $loose = 0; |
| 323 | $^H{charnames_full} = 1; |
| 324 | } |
| 325 | } |
| 326 | else { |
| 327 | |
| 328 | # Here, not a user alias. That means that loose matching may be in |
| 329 | # effect; will have to modify the input name. |
| 330 | $lookup_name = $name; |
| 331 | if ($loose) { |
| 332 | $lookup_name = uc $lookup_name; |
| 333 | |
| 334 | # Squeeze out all underscores |
| 335 | $lookup_name =~ s/_//g; |
| 336 | |
| 337 | # Remove all medial hyphens |
| 338 | $lookup_name =~ s/ (?<= \S ) - (?= \S )//gx; |
| 339 | |
| 340 | # Squeeze out all spaces |
| 341 | $lookup_name =~ s/\s//g; |
| 342 | } |
| 343 | |
| 344 | # Here, $lookup_name has been modified as necessary for looking in the |
| 345 | # hashes. Check the system alias files next. Most of these aliases are |
| 346 | # the same for both strict and loose matching. To save space, the ones |
| 347 | # which differ are in their own separate hash, which is checked if loose |
| 348 | # matching is selected and the regular match fails. To save time, the |
| 349 | # loose hashes could be expanded to include all aliases, and there would |
| 350 | # only have to be one check. But if someone specifies :loose, they are |
| 351 | # interested in convenience over speed, and the time for this second check |
| 352 | # is miniscule compared to the rest of the routine. |
| 353 | if (exists $system_aliases{$lookup_name}) { |
| 354 | $utf8 = $system_aliases{$lookup_name}; |
| 355 | } |
| 356 | # There are currently no entries in this hash, so don't waste time looking |
| 357 | # for them. But the code is retained for the unlikely possibility that |
| 358 | # some will be added in the future. |
| 359 | # elsif ($loose && exists $loose_system_aliases{$lookup_name}) { |
| 360 | # $utf8 = $loose_system_aliases{$lookup_name}; |
| 361 | # } |
| 362 | # if (exists $deprecated_aliases{$lookup_name}) { |
| 363 | # require warnings; |
| 364 | # warnings::warnif('deprecated', |
| 365 | # "Unicode character name \"$name\" is deprecated, use \"" |
| 366 | # . viacode(ord $deprecated_aliases{$lookup_name}) |
| 367 | # . "\" instead"); |
| 368 | # $utf8 = $deprecated_aliases{$lookup_name}; |
| 369 | # } |
| 370 | # There are currently no entries in this hash, so don't waste time looking |
| 371 | # for them. But the code is retained for the unlikely possibility that |
| 372 | # some will be added in the future. |
| 373 | # elsif ($loose && exists $loose_deprecated_aliases{$lookup_name}) { |
| 374 | # require warnings; |
| 375 | # warnings::warnif('deprecated', |
| 376 | # "Unicode character name \"$name\" is deprecated, use \"" |
| 377 | # . viacode(ord $loose_deprecated_aliases{$lookup_name}) |
| 378 | # . "\" instead"); |
| 379 | # $utf8 = $loose_deprecated_aliases{$lookup_name}; |
| 380 | # } |
| 381 | } |
| 382 | |
| 383 | my @off; # Offsets into table of pattern match begin and end |
| 384 | |
| 385 | # If haven't found it yet... |
| 386 | if (! defined $utf8) { |
| 387 | |
| 388 | # See if has looked this input up earlier. |
| 389 | if (! $loose && $^H{charnames_full} && exists $full_names_cache{$name}) { |
| 390 | $utf8 = $full_names_cache{$name}; |
| 391 | } |
| 392 | elsif ($loose && exists $loose_names_cache{$name}) { |
| 393 | $utf8 = $loose_names_cache{$name}; |
| 394 | } |
| 395 | else { # Here, must do a look-up |
| 396 | |
| 397 | # If full or loose matching succeeded, points to where to cache the |
| 398 | # result |
| 399 | my $cache_ref; |
| 400 | |
| 401 | ## Suck in the code/name list as a big string. |
| 402 | ## Lines look like: |
| 403 | ## "00052\tLATIN CAPITAL LETTER R\n" |
| 404 | # or |
| 405 | # "0052 0303\tLATIN CAPITAL LETTER R WITH TILDE\n" |
| 406 | $txt = do "unicore/Name.pl" unless $txt; |
| 407 | |
| 408 | ## @off will hold the index into the code/name string of the start and |
| 409 | ## end of the name as we find it. |
| 410 | |
| 411 | ## If :loose, look for a loose match; if :full, look for the name |
| 412 | ## exactly |
| 413 | # First, see if the name is one which is algorithmically determinable. |
| 414 | # The subroutine is included in Name.pl. The table contained in |
| 415 | # $txt doesn't contain these. Experiments show that checking |
| 416 | # for these before checking for the regular names has no |
| 417 | # noticeable impact on performance for the regular names, but |
| 418 | # the other way around slows down finding these immensely. |
| 419 | # Algorithmically determinables are not placed in the cache because |
| 420 | # that uses up memory, and finding these again is fast. |
| 421 | if (($loose || $^H{charnames_full}) |
| 422 | && (defined (my $ord = charnames::name_to_code_point_special($lookup_name, $loose)))) |
| 423 | { |
| 424 | $utf8 = pack("U", $ord); |
| 425 | } |
| 426 | else { |
| 427 | |
| 428 | # Not algorithmically determinable; look up in the table. The name |
| 429 | # will be turned into a regex, so quote any meta characters. |
| 430 | $lookup_name = quotemeta $lookup_name; |
| 431 | |
| 432 | if ($loose) { |
| 433 | |
| 434 | # For loose matches, $lookup_name has already squeezed out the |
| 435 | # non-essential characters. We have to add in code to make the |
| 436 | # squeezed version match the non-squeezed equivalent in the table. |
| 437 | # The only remaining hyphens are ones that start or end a word in |
| 438 | # the original. They have been quoted in $lookup_name so they look |
| 439 | # like "\-". Change all other characters except the backslash |
| 440 | # quotes for any metacharacters, and the final character, so that |
| 441 | # e.g., COLON gets transformed into: /C[- ]?O[- ]?L[- ]?O[- ]?N/ |
| 442 | $lookup_name =~ s/ (?! \\ -) # Don't do this to the \- sequence |
| 443 | ( [^-\\] ) # Nor the "-" within that sequence, |
| 444 | # nor the "\" that quotes metachars, |
| 445 | # but otherwise put the char into $1 |
| 446 | (?=.) # And don't do it for the final char |
| 447 | /$1\[- \]?/gx; # And add an optional blank or |
| 448 | # '-' after each $1 char |
| 449 | |
| 450 | # Those remaining hyphens were originally at the beginning or end of |
| 451 | # a word, so they can match either a blank before or after, but not |
| 452 | # both. (Keep in mind that they have been quoted, so are a '\-' |
| 453 | # sequence) |
| 454 | $lookup_name =~ s/\\ -/(?:- | -)/xg; |
| 455 | } |
| 456 | |
| 457 | # Do the lookup in the full table if asked for, and if succeeds |
| 458 | # save the offsets and set where to cache the result. |
| 459 | if (($loose || $^H{charnames_full}) && $txt =~ /\t$lookup_name$/m) { |
| 460 | @off = ($-[0] + 1, $+[0]); # The 1 is for the tab |
| 461 | $cache_ref = ($loose) ? \%loose_names_cache : \%full_names_cache; |
| 462 | } |
| 463 | else { |
| 464 | |
| 465 | # Here, didn't look for, or didn't find the name. |
| 466 | # If :short is allowed, see if input is like "greek:Sigma". |
| 467 | # Keep in mind that $lookup_name has had the metas quoted. |
| 468 | my $scripts_trie = ""; |
| 469 | my $name_has_uppercase; |
| 470 | if (($^H{charnames_short}) |
| 471 | && $lookup_name =~ /^ (?: \\ \s)* # Quoted space |
| 472 | (.+?) # $1 = the script |
| 473 | (?: \\ \s)* |
| 474 | \\ : # Quoted colon |
| 475 | (?: \\ \s)* |
| 476 | (.+?) # $2 = the name |
| 477 | (?: \\ \s)* $ |
| 478 | /xs) |
| 479 | { |
| 480 | # Even in non-loose matching, the script traditionally has been |
| 481 | # case insensitive |
| 482 | $scripts_trie = "\U$1"; |
| 483 | $lookup_name = $2; |
| 484 | |
| 485 | # Use original name to find its input casing, but ignore the |
| 486 | # script part of that to make the determination. |
| 487 | $save_input = $name if ! defined $save_input; |
| 488 | $name =~ s/.*?://; |
| 489 | $name_has_uppercase = $name =~ /[[:upper:]]/; |
| 490 | } |
| 491 | else { # Otherwise look in allowed scripts |
| 492 | $scripts_trie = $^H{charnames_scripts}; |
| 493 | |
| 494 | # Use original name to find its input casing |
| 495 | $name_has_uppercase = $name =~ /[[:upper:]]/; |
| 496 | } |
| 497 | |
| 498 | my $case = $name_has_uppercase ? "CAPITAL" : "SMALL"; |
| 499 | return if (! $scripts_trie || $txt !~ |
| 500 | /\t (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U$lookup_name $/xm); |
| 501 | |
| 502 | # Here have found the input name in the table. |
| 503 | @off = ($-[0] + 1, $+[0]); # The 1 is for the tab |
| 504 | } |
| 505 | |
| 506 | # Here, the input name has been found; we haven't set up the output, |
| 507 | # but we know where in the string |
| 508 | # the name starts. The string is set up so that for single characters |
| 509 | # (and not named sequences), the name is preceded immediately by a |
| 510 | # tab and 5 hex digits for its code, with a \n before those. Named |
| 511 | # sequences won't have the 7th preceding character be a \n. |
| 512 | # (Actually, for the very first entry in the table this isn't strictly |
| 513 | # true: subtracting 7 will yield -1, and the substr below will |
| 514 | # therefore yield the very last character in the table, which should |
| 515 | # also be a \n, so the statement works anyway.) |
| 516 | if (substr($txt, $off[0] - 7, 1) eq "\n") { |
| 517 | $utf8 = pack("U", CORE::hex substr($txt, $off[0] - 6, 5)); |
| 518 | |
| 519 | # Handle the single loose matching special case, in which two names |
| 520 | # differ only by a single medial hyphen. If the original had a |
| 521 | # hyphen (or more) in the right place, then it is that one. |
| 522 | $utf8 = $HANGUL_JUNGSEONG_O_E_utf8 |
| 523 | if $loose |
| 524 | && $utf8 eq $HANGUL_JUNGSEONG_OE_utf8 |
| 525 | && $name =~ m/O \s* - [-\s]* E/ix; |
| 526 | # Note that this wouldn't work if there were a 2nd |
| 527 | # OE in the name |
| 528 | } |
| 529 | else { |
| 530 | |
| 531 | # Here, is a named sequence. Need to go looking for the beginning, |
| 532 | # which is just after the \n from the previous entry in the table. |
| 533 | # The +1 skips past that newline, or, if the rindex() fails, to put |
| 534 | # us to an offset of zero. |
| 535 | my $charstart = rindex($txt, "\n", $off[0] - 7) + 1; |
| 536 | $utf8 = pack("U*", map { CORE::hex } |
| 537 | split " ", substr($txt, $charstart, $off[0] - $charstart - 1)); |
| 538 | } |
| 539 | } |
| 540 | |
| 541 | # Cache the input so as to not have to search the large table |
| 542 | # again, but only if it came from the one search that we cache. |
| 543 | # (Haven't bothered with the pain of sorting out scoping issues for the |
| 544 | # scripts searches.) |
| 545 | $cache_ref->{$name} = $utf8 if defined $cache_ref; |
| 546 | } |
| 547 | } |
| 548 | |
| 549 | |
| 550 | # Here, have the utf8. If the return is to be an ord, must be any single |
| 551 | # character. |
| 552 | if ($wants_ord) { |
| 553 | return ord($utf8) if length $utf8 == 1; |
| 554 | } |
| 555 | else { |
| 556 | |
| 557 | # Here, wants string output. If utf8 is acceptable, just return what |
| 558 | # we've got; otherwise attempt to convert it to non-utf8 and return that. |
| 559 | my $in_bytes = ($runtime) |
| 560 | ? (caller $runtime)[8] & $bytes::hint_bits |
| 561 | : $^H & $bytes::hint_bits; |
| 562 | return $utf8 if (! $in_bytes || utf8::downgrade($utf8, 1)) # The 1 arg |
| 563 | # means don't die on failure |
| 564 | } |
| 565 | |
| 566 | # Here, there is an error: either there are too many characters, or the |
| 567 | # result string needs to be non-utf8, and at least one character requires |
| 568 | # utf8. Prefer any official name over the input one for the error message. |
| 569 | if (@off) { |
| 570 | $name = substr($txt, $off[0], $off[1] - $off[0]) if @off; |
| 571 | } |
| 572 | else { |
| 573 | $name = (defined $save_input) ? $save_input : $_[0]; |
| 574 | } |
| 575 | |
| 576 | if ($wants_ord) { |
| 577 | # Only way to get here in this case is if result too long. Message |
| 578 | # assumes that our only caller that requires single char result is |
| 579 | # vianame. |
| 580 | carp "charnames::vianame() doesn't handle named sequences ($name). Use charnames::string_vianame() instead"; |
| 581 | return; |
| 582 | } |
| 583 | |
| 584 | # Only other possible failure here is from use bytes. |
| 585 | if ($runtime) { |
| 586 | carp not_legal_use_bytes_msg($name, $utf8); |
| 587 | return; |
| 588 | } else { |
| 589 | croak not_legal_use_bytes_msg($name, $utf8); |
| 590 | } |
| 591 | |
| 592 | } # lookup_name |
| 593 | |
| 594 | sub charnames { |
| 595 | |
| 596 | # For \N{...}. Looks up the character name and returns the string |
| 597 | # representation of it. |
| 598 | |
| 599 | # The first 0 arg means wants a string returned; the second that we are in |
| 600 | # compile time |
| 601 | return lookup_name($_[0], 0, 0); |
| 602 | } |
| 603 | |
| 604 | sub import |
| 605 | { |
| 606 | shift; ## ignore class name |
| 607 | |
| 608 | if (not @_) { |
| 609 | carp("'use charnames' needs explicit imports list"); |
| 610 | } |
| 611 | $^H{charnames} = \&charnames ; |
| 612 | $^H{charnames_ord_aliases} = {}; |
| 613 | $^H{charnames_name_aliases} = {}; |
| 614 | $^H{charnames_inverse_ords} = {}; |
| 615 | # New fields must be added to %dummy_H, and the code in lookup_name() |
| 616 | # that copies fields from the runtime structure |
| 617 | |
| 618 | ## |
| 619 | ## fill %h keys with our @_ args. |
| 620 | ## |
| 621 | my ($promote, %h, @args) = (0); |
| 622 | while (my $arg = shift) { |
| 623 | if ($arg eq ":alias") { |
| 624 | @_ or |
| 625 | croak ":alias needs an argument in charnames"; |
| 626 | my $alias = shift; |
| 627 | if (ref $alias) { |
| 628 | ref $alias eq "HASH" or |
| 629 | croak "Only HASH reference supported as argument to :alias"; |
| 630 | alias ($alias); |
| 631 | $promote = 1; |
| 632 | next; |
| 633 | } |
| 634 | if ($alias =~ m{:(\w+)$}) { |
| 635 | $1 eq "full" || $1 eq "loose" || $1 eq "short" and |
| 636 | croak ":alias cannot use existing pragma :$1 (reversed order?)"; |
| 637 | alias_file ($1) and $promote = 1; |
| 638 | next; |
| 639 | } |
| 640 | alias_file ($alias) and $promote = 1; |
| 641 | next; |
| 642 | } |
| 643 | if (substr($arg, 0, 1) eq ':' |
| 644 | and ! ($arg eq ":full" || $arg eq ":short" || $arg eq ":loose")) |
| 645 | { |
| 646 | warn "unsupported special '$arg' in charnames"; |
| 647 | next; |
| 648 | } |
| 649 | push @args, $arg; |
| 650 | } |
| 651 | |
| 652 | @args == 0 && $promote and @args = (":full"); |
| 653 | @h{@args} = (1) x @args; |
| 654 | |
| 655 | # Don't leave these undefined as are tested for in lookup_names |
| 656 | $^H{charnames_full} = delete $h{':full'} || 0; |
| 657 | $^H{charnames_loose} = delete $h{':loose'} || 0; |
| 658 | $^H{charnames_short} = delete $h{':short'} || 0; |
| 659 | my @scripts = map { uc quotemeta } keys %h; |
| 660 | |
| 661 | ## |
| 662 | ## If utf8? warnings are enabled, and some scripts were given, |
| 663 | ## see if at least we can find one letter from each script. |
| 664 | ## |
| 665 | if (warnings::enabled('utf8') && @scripts) { |
| 666 | $txt = do "unicore/Name.pl" unless $txt; |
| 667 | |
| 668 | for my $script (@scripts) { |
| 669 | if (not $txt =~ m/\t$script (?:CAPITAL |SMALL )?LETTER /) { |
| 670 | warnings::warn('utf8', "No such script: '$script'"); |
| 671 | $script = quotemeta $script; # Escape it, for use in the re. |
| 672 | } |
| 673 | } |
| 674 | } |
| 675 | |
| 676 | # %^H gets stringified, so serialize it ourselves so can extract the |
| 677 | # real data back later. |
| 678 | $^H{charnames_stringified_ords} = join ",", %{$^H{charnames_ord_aliases}}; |
| 679 | $^H{charnames_stringified_names} = join ",", %{$^H{charnames_name_aliases}}; |
| 680 | $^H{charnames_stringified_inverse_ords} = join ",", %{$^H{charnames_inverse_ords}}; |
| 681 | |
| 682 | # Modify the input script names for loose name matching if that is also |
| 683 | # specified, similar to the way the base character name is prepared. They |
| 684 | # don't (currently, and hopefully never will) have dashes. These go into a |
| 685 | # regex, and have already been uppercased and quotemeta'd. Squeeze out all |
| 686 | # input underscores, blanks, and dashes. Then convert so will match a blank |
| 687 | # between any characters. |
| 688 | if ($^H{charnames_loose}) { |
| 689 | for (my $i = 0; $i < @scripts; $i++) { |
| 690 | $scripts[$i] =~ s/[_ -]//g; |
| 691 | $scripts[$i] =~ s/ ( [^\\] ) (?= . ) /$1\\ ?/gx; |
| 692 | } |
| 693 | } |
| 694 | |
| 695 | $^H{charnames_scripts} = join "|", @scripts; # Stringifiy them as a trie |
| 696 | } # import |
| 697 | |
| 698 | # Cache of already looked-up values. This is set to only contain |
| 699 | # official values, and user aliases can't override them, so scoping is |
| 700 | # not an issue. |
| 701 | my %viacode; |
| 702 | |
| 703 | my $no_name_code_points_re = join "|", map { sprintf("%05X", |
| 704 | utf8::unicode_to_native($_)) } |
| 705 | 0x80, 0x81, 0x84, 0x99; |
| 706 | $no_name_code_points_re = qr/$no_name_code_points_re/; |
| 707 | |
| 708 | sub viacode { |
| 709 | |
| 710 | # Returns the name of the code point argument |
| 711 | |
| 712 | if (@_ != 1) { |
| 713 | carp "charnames::viacode() expects one argument"; |
| 714 | return; |
| 715 | } |
| 716 | |
| 717 | my $arg = shift; |
| 718 | |
| 719 | # This is derived from Unicode::UCD, where it is nearly the same as the |
| 720 | # function _getcode(), but here it makes sure that even a hex argument |
| 721 | # has the proper number of leading zeros, which is critical in |
| 722 | # matching against $txt below |
| 723 | # Must check if decimal first; see comments at that definition |
| 724 | my $hex; |
| 725 | if ($arg =~ $decimal_qr) { |
| 726 | $hex = sprintf "%05X", $arg; |
| 727 | } elsif ($arg =~ $hex_qr) { |
| 728 | $hex = CORE::hex $1; |
| 729 | $hex = utf8::unicode_to_native($hex) if $arg =~ /^[Uu]\+/; |
| 730 | # Below is the line that differs from the _getcode() source |
| 731 | $hex = sprintf "%05X", $hex; |
| 732 | } else { |
| 733 | carp("unexpected arg \"$arg\" to charnames::viacode()"); |
| 734 | return; |
| 735 | } |
| 736 | |
| 737 | return $viacode{$hex} if exists $viacode{$hex}; |
| 738 | |
| 739 | my $return; |
| 740 | |
| 741 | # If the code point is above the max in the table, there's no point |
| 742 | # looking through it. Checking the length first is slightly faster |
| 743 | if (length($hex) <= 5 || CORE::hex($hex) <= 0x10FFFF) { |
| 744 | $txt = do "unicore/Name.pl" unless $txt; |
| 745 | |
| 746 | # See if the name is algorithmically determinable. |
| 747 | my $algorithmic = charnames::code_point_to_name_special(CORE::hex $hex); |
| 748 | if (defined $algorithmic) { |
| 749 | $viacode{$hex} = $algorithmic; |
| 750 | return $algorithmic; |
| 751 | } |
| 752 | |
| 753 | # Return the official name, if exists. It's unclear to me (khw) at |
| 754 | # this juncture if it is better to return a user-defined override, so |
| 755 | # leaving it as is for now. |
| 756 | if ($txt =~ m/^$hex\t/m) { |
| 757 | |
| 758 | # The name starts with the next character and goes up to the |
| 759 | # next new-line. Using capturing parentheses above instead of |
| 760 | # @+ more than doubles the execution time in Perl 5.13 |
| 761 | $return = substr($txt, $+[0], index($txt, "\n", $+[0]) - $+[0]); |
| 762 | |
| 763 | # If not one of these 4 code points, return what we've found. |
| 764 | if ($hex !~ / ^ $no_name_code_points_re $ /x) { |
| 765 | $viacode{$hex} = $return; |
| 766 | return $return; |
| 767 | } |
| 768 | |
| 769 | # For backwards compatibility, we don't return the official name of |
| 770 | # the 4 code points if there are user-defined aliases for them -- so |
| 771 | # continue looking. |
| 772 | } |
| 773 | } |
| 774 | |
| 775 | # See if there is a user name for it, before giving up completely. |
| 776 | # First get the scoped aliases, give up if have none. |
| 777 | my $H_ref = (caller(1))[10]; |
| 778 | return if ! defined $return |
| 779 | && (! defined $H_ref |
| 780 | || ! exists $H_ref->{charnames_stringified_inverse_ords}); |
| 781 | |
| 782 | my %code_point_aliases; |
| 783 | if (defined $H_ref->{charnames_stringified_inverse_ords}) { |
| 784 | %code_point_aliases = split ',', |
| 785 | $H_ref->{charnames_stringified_inverse_ords}; |
| 786 | return $code_point_aliases{$hex} if exists $code_point_aliases{$hex}; |
| 787 | } |
| 788 | |
| 789 | # Here there is no user-defined alias, return any official one. |
| 790 | return $return if defined $return; |
| 791 | |
| 792 | if (CORE::hex($hex) > 0x10FFFF |
| 793 | && warnings::enabled('non_unicode')) |
| 794 | { |
| 795 | carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)"; |
| 796 | } |
| 797 | return; |
| 798 | |
| 799 | } # viacode |
| 800 | |
| 801 | 1; |
| 802 | |
| 803 | # ex: set ts=8 sts=2 sw=2 et: |