use strict;
use warnings;
use File::Spec;
-our $VERSION = '1.12';
+our $VERSION = '1.15';
-use bytes (); # for $bytes::hint_bits
+use bytes (); # for $bytes::hint_bits
my %system_aliases = (
# Icky 3.2 names with parentheses.
my $alias = ref $_[0] ? $_[0] : { @_ };
foreach my $name (keys %$alias) {
my $value = $alias->{$name};
- next unless defined $value; # Omit if screwed up.
+ next unless defined $value; # Omit if screwed up.
# Is slightly slower to just after this statement see if it is
# decimal, since we already know it is after having converted from
$value = CORE::hex $1;
}
if ($value =~ $decimal_qr) {
- $^H{charnames_ord_aliases}{$name} = $value;
+ $^H{charnames_ord_aliases}{$name} = $value;
# Use a canonical form.
- $^H{charnames_inverse_ords}{sprintf("%04X", $value)} = $name;
+ $^H{charnames_inverse_ords}{sprintf("%04X", $value)} = $name;
}
else {
- # XXX validate syntax when deprecation cycle complete. ie. start
- # with an alpha only, etc.
- $^H{charnames_name_aliases}{$name} = $value;
+ # XXX validate syntax when deprecation cycle complete. ie. start
+ # with an alpha only, etc.
+ $^H{charnames_name_aliases}{$name} = $value;
}
}
} # alias
0;
} # alias_file
+# For use when don't import anything. This structure must be kept in
+# sync with the one that import() fills up.
+my %dummy_H = (
+ charnames_stringified_names => "",
+ charnames_stringified_ords => "",
+ charnames_scripts => "",
+ charnames_full => 1,
+ charnames_short => 0,
+ );
+
sub lookup_name ($;$) {
my $runtime = (@_ > 1); # compile vs run time
- my $name = shift;
- my $hints_ref = shift;
+ my ($name, $hints_ref) = @_;
my $ord;
+ my $save_input;
if ($runtime) {
+
+ # If we didn't import anything (which happens with 'use charnames ()',
+ # substitute a dummy structure.
+ $hints_ref = \%dummy_H if ! defined $hints_ref
+ || ! defined $hints_ref->{charnames_full};
+
# At runtime, but currently not at compile time, $^H gets
# stringified, so un-stringify back to the original data structures.
# These get thrown away by perl before the next invocation
# Also fill in the hash with the non-stringified data.
+ # N.B. New fields must be also added to %dummy_H
- %{$^H{charnames_name_aliases}} = split ',', $hints_ref->{charnames_stringified_names};
- %{$^H{charnames_ord_aliases}} = split ',', $hints_ref->{charnames_stringified_ords};
- @{$^H{charnames_scripts}} = split ',', $hints_ref->{charnames_stringified_scripts};
+ %{$^H{charnames_name_aliases}} = split ',',
+ $hints_ref->{charnames_stringified_names};
+ %{$^H{charnames_ord_aliases}} = split ',',
+ $hints_ref->{charnames_stringified_ords};
+ $^H{charnames_scripts} = $hints_ref->{charnames_scripts};
$^H{charnames_full} = $hints_ref->{charnames_full};
$^H{charnames_short} = $hints_ref->{charnames_short};
}
}
elsif (exists $^H{charnames_name_aliases}{$name}) {
$name = $^H{charnames_name_aliases}{$name};
+ $save_input = $name; # Cache the result for any error message
}
elsif (exists $system_aliases{$name}) {
$ord = $system_aliases{$name};
if (! defined $ord) {
-
+ # See if has looked this up earlier.
if ($^H{charnames_full} && exists $full_names_cache{$name}) {
$ord = $full_names_cache{$name};
}
## end of the name as we find it.
## If :full, look for the name exactly; runtime implies full
- my $found_full = 0; # Tells us if can cache the result
+ my $found_full_in_table = 0; # Tells us if can cache the result
if ($^H{charnames_full}) {
- if ($txt =~ /\t\t\Q$name\E$/m) {
- @off = ($-[0] + 2, $+[0]); # The 2 is for the 2 tabs
- $found_full = 1;
- }
+
+ # See if the name is one which is algorithmically determinable.
+ # The subroutine is included in Name.pl. The table contained in
+ # $txt doesn't contain these. Experiments show that checking
+ # for these before checking for the regular names has no
+ # noticeable impact on performance for the regular names, but
+ # the other way around slows down finding these immensely.
+ # Algorithmically determinables are not placed in the cache (that
+ # $found_full_in_table indicates) because that uses up memory,
+ # and finding these again is fast.
+ if (! defined ($ord = name_to_code_point_special($name))) {
+
+ # Not algorthmically determinable; look up in the table.
+ if ($txt =~ /\t\t\Q$name\E$/m) {
+ @off = ($-[0] + 2, $+[0]); # The 2 is for the 2 tabs
+ $found_full_in_table = 1;
+ }
+ }
}
- # If we didn't get it above keep looking
- if (! $found_full) {
-
- # If :short is allowed, look for the short name, which is like
- # "greek:Sigma"
- if (($^H{charnames_short}) && $name =~ /^(.+?):(.+)/s) {
- my ($script, $cname) = ($1, $2);
- my $case = $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
- if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U\Q$cname\E$/m) {
- @off = ($-[0] + 2, $+[0]);
- }
- }
-
- ## If we still don't have it, check for the name among the loaded
- ## scripts.
- unless (@off) {
- my $case = $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
- for my $script (@{$^H{charnames_scripts}}) {
- if ($txt =~ m/\t\t$script (?:$case )?LETTER \U\Q$name\E$/m) {
- @off = ($-[0] + 2, $+[0]);
- last;
- }
- }
-
- ## If we don't have it by now, give up.
- unless (@off) {
- return if $runtime;
- carp "Unknown charname '$name'";
- return 0xFFFD;
- }
- }
+ # If we didn't get it above, keep looking
+ if (! $found_full_in_table && ! defined $ord) {
+
+ # If :short is allowed, see if input is like "greek:Sigma".
+ my $scripts_trie;
+ if (($^H{charnames_short})
+ && $name =~ /^ \s* (.+?) \s* : \s* (.+?) \s* $ /xs)
+ {
+ $scripts_trie = "\U\Q$1";
+ $name = $2;
+ }
+ else {
+ $scripts_trie = $^H{charnames_scripts};
+ }
+
+ my $case = $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
+ if ($txt !~
+ /\t\t (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U\Q$name\E $/xm)
+ {
+ # Here we still don't have it, give up.
+ return if $runtime;
+
+ # May have zapped input name, get it again.
+ $name = (defined $save_input) ? $save_input : $_[0];
+ carp "Unknown charname '$name'";
+ return 0xFFFD;
+ }
+
+ @off = ($-[0] + 2, $+[0]);
}
- ##
- ## Now know where in the string the name starts.
- ## The code, in hex, is before that.
- ##
- ## The code can be 4-6 characters long, so we've got to sort of
- ## go look for it, just after the newline that comes before $off[0].
- ##
- ## This would be much easier if unicore/Name.pl had info in
- ## a name/code order, instead of code/name order.
- ##
- ## The +1 after the rindex() is to skip past the newline we're finding,
- ## or, if the rindex() fails, to put us to an offset of zero.
- ##
- my $hexstart = rindex($txt, "\n", $off[0]) + 1;
-
- ## we know where it starts, so turn into number -
- ## the ordinal for the char.
- $ord = CORE::hex substr($txt, $hexstart, $off[0] - 2 - $hexstart);
+ if (! defined $ord) {
+ ##
+ ## Now know where in the string the name starts.
+ ## The code, in hex, is before that.
+ ##
+ ## The code can be 4-6 characters long, so we've got to sort of
+ ## go look for it, just after the newline that comes before $off[0].
+ ##
+ ## This would be much easier if unicore/Name.pl had info in
+ ## a name/code order, instead of code/name order.
+ ##
+ ## The +1 after the rindex() is to skip past the newline we're finding,
+ ## or, if the rindex() fails, to put us to an offset of zero.
+ ##
+ my $hexstart = rindex($txt, "\n", $off[0]) + 1;
+
+ ## we know where it starts, so turn into number -
+ ## the ordinal for the char.
+ $ord = CORE::hex substr($txt, $hexstart, $off[0] - 2 - $hexstart);
+ }
# Cache the input so as to not have to search the large table
# again, but only if it came from the one search that we cache.
- $full_names_cache{$name} = $ord if $found_full;
+ $full_names_cache{$name} = $ord if $found_full_in_table;
}
}
# Here is compile time, "use bytes" is in effect, and the character
# won't fit in a byte
- # Use the official name if have one
- $name = substr($txt, $off[0], $off[1] - $off[0]) if @off;
+ # Prefer any official name over the input one.
+ if (@off) {
+ $name = substr($txt, $off[0], $off[1] - $off[0]) if @off;
+ }
+ else {
+ $name = (defined $save_input) ? $save_input : $_[0];
+ }
croak not_legal_use_bytes_msg($name, $ord);
} # lookup_name
$^H{charnames_ord_aliases} = {};
$^H{charnames_name_aliases} = {};
$^H{charnames_inverse_ords} = {};
+ # New fields must be added to %dummy_H, and the code in lookup_name()
+ # that copies fields from the runtime structure
##
## fill %h keys with our @_ args.
while (my $arg = shift) {
if ($arg eq ":alias") {
@_ or
- croak ":alias needs an argument in charnames";
+ croak ":alias needs an argument in charnames";
my $alias = shift;
if (ref $alias) {
- ref $alias eq "HASH" or
- croak "Only HASH reference supported as argument to :alias";
- alias ($alias);
- next;
+ ref $alias eq "HASH" or
+ croak "Only HASH reference supported as argument to :alias";
+ alias ($alias);
+ next;
}
if ($alias =~ m{:(\w+)$}) {
- $1 eq "full" || $1 eq "short" and
- croak ":alias cannot use existing pragma :$1 (reversed order?)";
- alias_file ($1) and $promote = 1;
- next;
+ $1 eq "full" || $1 eq "short" and
+ croak ":alias cannot use existing pragma :$1 (reversed order?)";
+ alias_file ($1) and $promote = 1;
+ next;
}
alias_file ($alias);
next;
@args == 0 && $promote and @args = (":full");
@h{@args} = (1) x @args;
- $^H{charnames_full} = delete $h{':full'};
- $^H{charnames_short} = delete $h{':short'};
- $^H{charnames_scripts} = [map uc, keys %h];
+ $^H{charnames_full} = delete $h{':full'} || 0; # Don't leave undefined,
+ # as tested for in
+ # lookup_names
+ $^H{charnames_short} = delete $h{':short'} || 0;
+ my @scripts = map uc, keys %h;
##
## If utf8? warnings are enabled, and some scripts were given,
## see if at least we can find one letter from each script.
##
- if (warnings::enabled('utf8') && @{$^H{charnames_scripts}}) {
+ if (warnings::enabled('utf8') && @scripts) {
$txt = do "unicore/Name.pl" unless $txt;
- for my $script (@{$^H{charnames_scripts}}) {
+ for my $script (@scripts) {
if (not $txt =~ m/\t\t$script (?:CAPITAL |SMALL )?LETTER /) {
- warnings::warn('utf8', "No such script: '$script'");
+ warnings::warn('utf8', "No such script: '$script'");
+ $script = quotemeta $script; # Escape it, for use in the re.
}
}
}
$^H{charnames_stringified_ords} = join ",", %{$^H{charnames_ord_aliases}};
$^H{charnames_stringified_names} = join ",", %{$^H{charnames_name_aliases}};
$^H{charnames_stringified_inverse_ords} = join ",", %{$^H{charnames_inverse_ords}};
- $^H{charnames_stringified_scripts} = join ",", @{$^H{charnames_scripts}};
+ $^H{charnames_scripts} = join "|", @scripts; # Stringifiy them as a trie
} # import
# Cache of already looked-up values. This is set to only contain
if (length($hex) <= 5 || CORE::hex($hex) <= 0x10FFFF) {
$txt = do "unicore/Name.pl" unless $txt;
+ # See if the name is algorithmically determinable.
+ my $algorithmic = code_point_to_name_special(CORE::hex $hex);
+ if (defined $algorithmic) {
+ $viacode{$hex} = $algorithmic;
+ return $algorithmic;
+ }
+
# 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\t/m) {
- # The name starts with the next character and goes up to the
- # next new-line. Using capturing parentheses above instead of
- # @+ more than doubles the execution time in Perl 5.13
+ # The name starts with the next character and goes up to the
+ # next new-line. Using capturing parentheses above instead of
+ # @+ more than doubles the execution time in Perl 5.13
$viacode{$hex} = substr($txt, $+[0], index($txt, "\n", $+[0]) - $+[0]);
- return $viacode{$hex};
+ return $viacode{$hex};
}
}
# See if there is a user name for it, before giving up completely.
- # First get the scoped aliases.
+ # First get the scoped aliases, give up if have none.
+ my $H_ref = (caller(0))[10];
+ return if ! defined $H_ref
+ || ! exists $H_ref->{charnames_stringified_inverse_ords};
+
my %code_point_aliases = split ',',
- (caller(0))[10]->{charnames_stringified_inverse_ords};
+ $H_ref->{charnames_stringified_inverse_ords};
if (! exists $code_point_aliases{$hex}) {
if (CORE::hex($hex) > 0x10FFFF) {
carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)";
name character
- END OF PROTECTED AREA END OF GUARDED AREA, U+0097
+ END OF PROTECTED AREA END OF GUARDED AREA, U+0097
HIGH OCTET PRESET U+0081
HOP U+0081
IND U+0084
following magic incantation:
sub import {
- shift;
- $^H{charnames} = \&translator;
+ shift;
+ $^H{charnames} = \&translator;
}
Here translator() is a subroutine which takes I<CHARNAME> as an
in C<bytes> mode and out of it, the function should check the current
state of C<bytes>-flag as in:
- use bytes (); # for $bytes::hint_bits
+ use bytes (); # for $bytes::hint_bits
sub translator {
- if ($^H & $bytes::hint_bits) {
- return bytes_translator(@_);
- }
- else {
- return utf8_translator(@_);
- }
+ if ($^H & $bytes::hint_bits) {
+ return bytes_translator(@_);
+ }
+ else {
+ return utf8_translator(@_);
+ }
}
See L</CUSTOM ALIASES> above for restrictions on I<CHARNAME>.
bytes>> is in effect when a chr is returned, and if that chr won't fit
into a byte, C<undef> is returned instead.
-All the Hangul syllable characters are treated as having no names, as
-are almost all the CJK Unicode characters that have their code points as
-part of their names.
-
Names must be ASCII characters only, which means that you are out of luck if
you want to create aliases in a language where some or all the characters of
the desired aliases are non-ASCII.
=cut
-# ex: set ts=8 sts=2 sw=2 noet:
+# ex: set ts=8 sts=2 sw=2 et:
https://perl5.git.perl.org / perl5.git / blobdiff