summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/_charnames.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/_charnames.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/_charnames.pm99
1 files changed, 64 insertions, 35 deletions
diff --git a/Master/tlpkg/tlperl/lib/_charnames.pm b/Master/tlpkg/tlperl/lib/_charnames.pm
index 62ee39560de..4ab9411f8ea 100644
--- a/Master/tlpkg/tlperl/lib/_charnames.pm
+++ b/Master/tlpkg/tlperl/lib/_charnames.pm
@@ -7,7 +7,7 @@ package _charnames;
use strict;
use warnings;
use File::Spec;
-our $VERSION = '1.31';
+our $VERSION = '1.36';
use unicore::Name; # mktables-generated algorithmically-defined names
use bytes (); # for $bytes::hint_bits
@@ -77,11 +77,8 @@ my %system_aliases = (
#my %loose_system_aliases = (
#);
-my %deprecated_aliases = (
- # Use of these gives deprecated message.
- # Unicode 6.0 co-opted this for U+1F514, so deprecate it for now.
- 'BELL' => pack("U", 0x07),
-);
+#my %deprecated_aliases;
+#$deprecated_aliases{'BELL'} = pack("U", 0x07) if $^V lt v5.17.0;
#my %loose_deprecated_aliases = (
#);
@@ -146,8 +143,12 @@ sub carp
sub alias (@) # Set up a single alias
{
+ my @errors;
+
my $alias = ref $_[0] ? $_[0] : { @_ };
- foreach my $name (keys %$alias) {
+ foreach my $name (sort keys %$alias) { # Sort only because it helps having
+ # deterministic output for
+ # t/lib/charnames/alias
my $value = $alias->{$name};
next unless defined $value; # Omit if screwed up.
@@ -159,18 +160,53 @@ sub alias (@) # Set up a single alias
$value = CORE::hex $1;
}
if ($value =~ $decimal_qr) {
- no warnings qw(non_unicode surrogate nonchar); # Allow any non-malformed
+ no warnings qw(non_unicode surrogate nonchar); # Allow any of these
$^H{charnames_ord_aliases}{$name} = pack("U", $value);
# Use a canonical form.
$^H{charnames_inverse_ords}{sprintf("%05X", $value)} = $name;
}
else {
- # XXX validate syntax when deprecation cycle complete. ie. start
- # with an alpha only, etc.
- $^H{charnames_name_aliases}{$name} = $value;
+ # This regex needs to be sync'd with the code in toke.c that checks
+ # for the same thing
+ if ($name !~ / ^
+ \p{_Perl_Charname_Begin}
+ \p{_Perl_Charname_Continue}*
+ $ /x) {
+
+ push @errors, $name;
+ }
+ else {
+ $^H{charnames_name_aliases}{$name} = $value;
+
+ if (warnings::enabled('deprecated')) {
+ if ($name =~ / ( .* \s ) ( \s* ) $ /x) {
+ carp "Trailing white-space in a charnames alias definition is deprecated; marked by <-- HERE in '$1 <-- HERE " . $2 . "'";
+ }
+
+ # Use '+' instead of '*' in this regex, because any trailing
+ # blanks have already been warned about.
+ if ($name =~ / ( .*? \s{2} ) ( .+ ) /x) {
+ carp "A sequence of multiple spaces in a charnames alias definition is deprecated; marked by <-- HERE in '$1 <-- HERE " . $2 . "'";
+ }
+ }
+ }
}
}
+
+ # We find and output all errors from this :alias definition, rather than
+ # failing on the first one, so fewer runs are needed to get it to compile
+ if (@errors) {
+ foreach my $name (@errors) {
+ my $ok = "";
+ $ok = $1 if $name =~ / ^ ( \p{Alpha} [-\p{XPosixWord} ():\xa0]* ) /x;
+ my $first_bad = substr($name, length($ok), 1);
+ $name = "Invalid character in charnames alias definition; marked by <-- HERE in '$ok$first_bad<-- HERE " . substr($name, length($ok) + 1) . "'";
+ }
+ croak join "\n", @errors;
+ }
+
+ return;
} # alias
sub not_legal_use_bytes_msg {
@@ -191,11 +227,11 @@ sub alias_file ($) # Reads a file containing alias definitions
if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
$file = $arg;
}
- elsif ($arg =~ m/^\w+$/) {
+ elsif ($arg =~ m/ ^ \p{_Perl_IDStart} \p{_Perl_IDCont}* $/x) {
$file = "unicore/${arg}_alias.pl";
}
else {
- croak "Charnames alias files can only have identifier characters";
+ croak "Charnames alias file names can only have identifier characters";
}
if (my @alias = do $file) {
@alias == 1 && !defined $alias[0] and
@@ -320,14 +356,14 @@ sub lookup_name ($$$) {
# elsif ($loose && exists $loose_system_aliases{$lookup_name}) {
# $utf8 = $loose_system_aliases{$lookup_name};
# }
- if (exists $deprecated_aliases{$lookup_name}) {
- require warnings;
- warnings::warnif('deprecated',
- "Unicode character name \"$name\" is deprecated, use \""
- . viacode(ord $deprecated_aliases{$lookup_name})
- . "\" instead");
- $utf8 = $deprecated_aliases{$lookup_name};
- }
+# if (exists $deprecated_aliases{$lookup_name}) {
+# require warnings;
+# warnings::warnif('deprecated',
+# "Unicode character name \"$name\" is deprecated, use \""
+# . viacode(ord $deprecated_aliases{$lookup_name})
+# . "\" instead");
+# $utf8 = $deprecated_aliases{$lookup_name};
+# }
# There are currently no entries in this hash, so don't waste time looking
# for them. But the code is retained for the unlikely possibility that
# some will be added in the future.
@@ -457,18 +493,8 @@ sub lookup_name ($$$) {
}
my $case = $name_has_uppercase ? "CAPITAL" : "SMALL";
- if (! $scripts_trie
- || $txt !~
- /\t (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U$lookup_name $/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 ($wants_ord) ? 0xFFFD : pack("U", 0xFFFD);
- }
+ return if (! $scripts_trie || $txt !~
+ /\t (?: $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
@@ -599,6 +625,7 @@ sub import
ref $alias eq "HASH" or
croak "Only HASH reference supported as argument to :alias";
alias ($alias);
+ $promote = 1;
next;
}
if ($alias =~ m{:(\w+)$}) {
@@ -607,7 +634,7 @@ sub import
alias_file ($1) and $promote = 1;
next;
}
- alias_file ($alias);
+ alias_file ($alias) and $promote = 1;
next;
}
if (substr($arg, 0, 1) eq ':'
@@ -752,7 +779,9 @@ sub viacode {
# Here there is no user-defined alias, return any official one.
return $return if defined $return;
- if (CORE::hex($hex) > 0x10FFFF) {
+ if (CORE::hex($hex) > 0x10FFFF
+ && warnings::enabled('non_unicode'))
+ {
carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)";
}
return;