make /\p{isUserDefined}/ die on taint

If the string which contains the name of a user-defined character property
function is tainted, then die rather than calling that function.
See [perl #82616].

1 files changed, 19 insertions, 6 deletions

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index 41cace887b..e0cdc7bb46 100644
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -109,8 +109,18 @@ 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}($caseless);
                         last GETFILE;
                     }
@@ -444,11 +454,12 @@ sub croak { require Carp; Carp::croak(@_) }
         my $bits = $minbits;
 
         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), $_ ] }
@@ -478,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;