diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/utf8_heavy.pl')
-rw-r--r-- | Master/tlpkg/tlperl/lib/utf8_heavy.pl | 128 |
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; } } |