summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/utf8_heavy.pl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/utf8_heavy.pl')
-rw-r--r--Master/tlpkg/tlperl/lib/utf8_heavy.pl128
1 files changed, 106 insertions, 22 deletions
diff --git a/Master/tlpkg/tlperl/lib/utf8_heavy.pl b/Master/tlpkg/tlperl/lib/utf8_heavy.pl
index d473dd2a424..94c132d0995 100644
--- a/Master/tlpkg/tlperl/lib/utf8_heavy.pl
+++ b/Master/tlpkg/tlperl/lib/utf8_heavy.pl
@@ -21,11 +21,20 @@ sub croak { require Carp; Carp::croak(@_) }
# are specified that don't exactly match.
my $min_floating_slop;
+ # To guard against this program calling something that in turn ends up
+ # calling this program with the same inputs, and hence infinitely
+ # recursing, we keep a stack of the properties that are currently in
+ # progress, pushed upon entry, popped upon return.
+ my @recursed;
+
sub SWASHNEW {
my ($class, $type, $list, $minbits, $none) = @_;
local $^D = 0 if $^D;
- print STDERR __LINE__, ": ", join(", ", @_), "\n" if DEBUG;
+ $class = "" unless defined $class;
+ print STDERR __LINE__, ": class=$class, type=$type, list=",
+ (defined $list) ? $list : ':undef:',
+ ", minbits=$minbits, none=$none\n" if DEBUG;
##
## Get the list of codepoints for the type.
@@ -70,15 +79,29 @@ sub croak { require Carp; Carp::croak(@_) }
if ($type)
{
+
+ # Verify that this isn't a recursive call for this property.
+ # Can't use croak, as it may try to recurse here itself.
+ my $class_type = $class . "::$type";
+ if (grep { $_ eq $class_type } @recursed) {
+ CORE::die "panic: Infinite recursion in SWASHNEW for '$type'\n";
+ }
+ push @recursed, $class_type;
+
$type =~ s/^\s+//;
$type =~ s/\s+$//;
- print STDERR __LINE__, ": type = $type\n" if DEBUG;
+ # regcomp.c surrounds the property name with '__" and '_i' if this
+ # is to be caseless matching.
+ my $caseless = $type =~ s/^__(.*)_i$/$1/;
+
+ print STDERR __LINE__, ": type=$type, caseless=$caseless\n" if DEBUG;
GETFILE:
{
##
- ## It could be a user-defined property.
+ ## It could be a user-defined property. Look in current
+ ## package if no package given
##
my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
@@ -86,24 +109,55 @@ sub croak { require Carp; Carp::croak(@_) }
if (defined $caller1 && $type =~ /^I[ns]\w+$/) {
my $prop = "${caller1}::$type";
if (exists &{$prop}) {
+ # stolen from Scalar::Util::PP::tainted()
+ my $tainted;
+ {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ local $^W = 0;
+ no warnings;
+ eval { kill 0 * $prop };
+ $tainted = 1 if $@ =~ /^Insecure/;
+ }
+ die "Insecure user-defined property \\p{$prop}\n"
+ if $tainted;
no strict 'refs';
-
- $list = &{$prop};
+ $list = &{$prop}($caseless);
last GETFILE;
}
}
- require "$unicore_dir/Heavy.pl";
+ # During Perl's compilation, this routine may be called before
+ # the tables are constructed. If so, we have a chicken/egg
+ # problem. If we die, the tables never get constructed, so
+ # keep going, but return an empty table so only what the code
+ # has compiled in internally (currently ASCII/Latin1 range
+ # matching) will work.
+ BEGIN {
+ # Poor man's constant, to avoid a run-time check.
+ $utf8::{miniperl}
+ = \! defined &DynaLoader::boot_DynaLoader;
+ }
+ if (miniperl) {
+ eval "require '$unicore_dir/Heavy.pl'";
+ last GETFILE if $@;
+ }
+ else {
+ require "$unicore_dir/Heavy.pl";
+ }
+ BEGIN { delete $utf8::{miniperl} }
- # Everything is caseless matching
- my $property_and_table = lc $type;
+ # All property names are matched caselessly
+ my $property_and_table = CORE::lc $type;
print STDERR __LINE__, ": $property_and_table\n" if DEBUG;
# See if is of the compound form 'property=value', where the
# value indicates the table we should use.
my ($property, $table, @remainder) =
split /\s*[:=]\s*/, $property_and_table, -1;
- return $type if @remainder;
+ if (@remainder) {
+ pop @recursed if @recursed;
+ return $type;
+ }
my $prefix;
if (! defined $table) {
@@ -122,7 +176,10 @@ sub croak { require Carp; Carp::croak(@_) }
# And convert to canonical form. Quit if not valid.
$property = $utf8::loose_property_name_of{$property};
- return $type unless defined $property;
+ if (! defined $property) {
+ pop @recursed if @recursed;
+ return $type;
+ }
$prefix = "$property=";
@@ -132,14 +189,20 @@ sub croak { require Carp; Carp::croak(@_) }
print STDERR __LINE__, ": table=$table\n" if DEBUG;
# Don't allow leading nor trailing slashes
- return $type if $table =~ / ^ \/ | \/ $ /x;
+ if ($table =~ / ^ \/ | \/ $ /x) {
+ pop @recursed if @recursed;
+ return $type;
+ }
# Split on slash, in case it is a rational, like \p{1/5}
my @parts = split qr{ \s* / \s* }x, $table, -1;
print __LINE__, ": $type\n" if @parts > 2 && DEBUG;
# Can have maximum of one slash
- return $type if @parts > 2;
+ if (@parts > 2) {
+ pop @recursed if @recursed;
+ return $type;
+ }
foreach my $part (@parts) {
print __LINE__, ": part=$part\n" if DEBUG;
@@ -172,8 +235,10 @@ sub croak { require Carp; Carp::croak(@_) }
# Result better look like a number. (This test is
# needed because, for example could have a plus in
# the middle.)
- return $type if $part
- !~ / ^ -? [0-9]+ ( \. [0-9]+)? $ /x;
+ if ($part !~ / ^ -? [0-9]+ ( \. [0-9]+)? $ /x) {
+ pop @recursed if @recursed;
+ return $type;
+ }
}
# If a rational...
@@ -277,7 +342,10 @@ sub croak { require Carp; Carp::croak(@_) }
}
# Quit if didn't find one.
- return $type unless defined $table;
+ if (! defined $table) {
+ pop @recursed if @recursed;
+ return $type;
+ }
}
}
print STDERR __LINE__, ": $property=$table\n" if DEBUG;
@@ -307,6 +375,12 @@ sub croak { require Carp; Carp::croak(@_) }
if ($utf8::why_deprecated{$file}) {
warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};");
}
+
+ if ($caseless
+ && exists $utf8::caseless_equivalent{$property_and_table})
+ {
+ $file = $utf8::caseless_equivalent{$property_and_table};
+ }
$file= "$unicore_dir/lib/$file.pl";
last GETFILE;
}
@@ -325,6 +399,7 @@ sub croak { require Carp; Carp::croak(@_) }
no strict 'refs';
$list = &{$map};
+ warnings::warnif('deprecated', "User-defined case-mapping '$type' is deprecated");
last GETFILE;
}
}
@@ -346,6 +421,7 @@ sub croak { require Carp; Carp::croak(@_) }
## out what to do with $type. Ouch.
##
+ pop @recursed if @recursed;
return $type;
}
@@ -362,6 +438,7 @@ sub croak { require Carp; Carp::croak(@_) }
my $found = $Cache{$class, $file};
if ($found and ref($found) eq $class) {
print STDERR __LINE__, ": Returning cached '$file' for \\p{$type}\n" if DEBUG;
+ pop @recursed if @recursed;
return $found;
}
@@ -376,13 +453,13 @@ sub croak { require Carp; Carp::croak(@_) }
my $extras;
my $bits = $minbits;
- my $ORIG = $list;
if ($list) {
+ my $taint = substr($list,0,0); # maintain taint
my @tmp = split(/^/m, $list);
my %seen;
no warnings;
- $extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
- $list = join '',
+ $extras = join '', $taint, grep /^[^0-9a-fA-F]/, @tmp;
+ $list = join '', $taint,
map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { /^([0-9a-fA-F]+)/; [ CORE::hex($1), $_ ] }
@@ -412,11 +489,13 @@ sub croak { require Carp; Carp::croak(@_) }
my @extras;
if ($extras) {
for my $x ($extras) {
+ my $taint = substr($x,0,0); # maintain taint
pos $x = 0;
while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
- my $char = $1;
- my $name = $2;
- print STDERR __LINE__, ": $1 => $2\n" if DEBUG;
+ my $char = "$1$taint";
+ my $name = "$2$taint";
+ print STDERR __LINE__, ": char [$char] => name [$name]\n"
+ if DEBUG;
if ($char =~ /[-+!&]/) {
my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really
my $subobj;
@@ -429,7 +508,10 @@ sub croak { require Carp; Carp::croak(@_) }
elsif ($c =~ /^([0-9a-fA-F]+)/) {
$subobj = utf8->SWASHNEW("", $c, $minbits, 0);
}
- return $subobj unless ref $subobj;
+ if (! ref $subobj) {
+ pop @recursed if @recursed && $type;
+ return $subobj;
+ }
push @extras, $name => $subobj;
$bits = $subobj->{BITS} if $bits < $subobj->{BITS};
}
@@ -457,6 +539,8 @@ sub croak { require Carp; Carp::croak(@_) }
$Cache{$class, $file} = $SWASH;
}
+ pop @recursed if @recursed && $type;
+
return $SWASH;
}
}