# 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__, ": class=$class, type=$type, list=$list, minbits=$minbits, none=$none\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.
## $none is undocumented, so I'm (khw) trying to do some documentation
## of it now. It appears to be if there is a mapping in an input file
## that maps to 'XXXX', then that is replaced by $none+1, expressed in
- ## hexadecimal. The only place I found it possibly used was in
- ## S_pmtrans in op.c.
+ ## hexadecimal. It is used somehow in tr///.
##
## To make the parsing of $type clear, this code takes the a rather
## unorthodox approach of last'ing out of the block once we have the
## info we need. Were this to be a subroutine, the 'last' would just
## be a 'return'.
##
+ # If a problem is found $type is returned;
+ # Upon success, a new (or cached) blessed object is returned with
+ # keys TYPE, BITS, EXTRAS, LIST, and NONE with values having the
+ # same meanings as the input parameters.
+ # SPECIALS contains a reference to any special-treatment hash in the
+ # INVERT_IT is non-zero if the result should be inverted before use
my $file; ## file to load data from, and also part of the %Cache key.
my $ListSorted = 0;
# Change this to get a different set of Unicode tables
my $unicore_dir = 'unicore';
+ my $invert_it = 0;
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:
{
my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
- if (defined $caller1 && $type =~ /^(?:\w+)$/) {
+ 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;
}
}
}
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) {
# 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=";
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;
# 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...
}
# 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;
# Add the constant and go fetch it in.
if (defined $file) {
+
+ # A beginning ! means to invert
+ $invert_it = $file =~ s/^!//;
+
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;
}
no strict 'refs';
$list = &{$map};
+ warnings::warnif('deprecated', "User-defined case-mapping '$type' is deprecated");
last GETFILE;
}
}
## is to use Unicode::UCD.
##
if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) {
+
+ # Fail if wanting a binary property, as these aren't.
+ if ($minbits == 1) {
+ pop @recursed if @recursed;
+ return $type;
+ }
$file = "$unicore_dir/To/$1.pl";
## would like to test to see if $file actually exists....
last GETFILE;
## out what to do with $type. Ouch.
##
+ pop @recursed if @recursed;
return $type;
}
##
my $found = $Cache{$class, $file};
if ($found and ref($found) eq $class) {
- print STDERR __LINE__, ": Returning cached '$file' for \\p{$type}\n" if DEBUG;
+ print STDERR __LINE__, ": Returning cached '$file' for \\p{$type}; invert_it=$invert_it\n" if DEBUG;
+ pop @recursed if @recursed;
+ $found->{'INVERT_IT'} = $invert_it;
return $found;
}
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), $_ ] }
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;
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};
}
}
if (DEBUG) {
- print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none";
+ print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none, INVERT_IT => $invert_it";
print STDERR "\nLIST =>\n$list" if defined $list;
print STDERR "\nEXTRAS =>\n$extras" if defined $extras;
print STDERR "\n";
if ($file) {
$Cache{$class, $file} = $SWASH;
+ if ($type
+ && exists $utf8::SwashInfo{$type}
+ && exists $utf8::SwashInfo{$type}{'specials_name'})
+ {
+ my $specials_name = $utf8::SwashInfo{$type}{'specials_name'};
+ no strict "refs";
+ print STDERR "\nspecials_name => $SWASH->{'SPECIALS'}\n" if DEBUG;
+ $SWASH->{'SPECIALS'} = \%$specials_name;
+ }
+ $SWASH->{'INVERT_IT'} = $invert_it;
}
+ pop @recursed if @recursed && $type;
+
return $SWASH;
}
}
https://perl5.git.perl.org / perl5.git / blobdiff