This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[perl #121854] use re 'taint' regression
[perl5.git] / t / op / taint.t
diff --git a/t/op/taint.t b/t/op/taint.t
index 9cea740..aaf556a 100644 (file)
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -17,7 +17,7 @@ BEGIN {
 use strict;
 use Config;
 
 use strict;
 use Config;
 
-plan tests => 794;
+plan tests => 800;
 
 $| = 1;
 
 
 $| = 1;
 
@@ -152,7 +152,7 @@ my $TEST = 'TEST';
        while (my $v = $vars[0]) {
            local $ENV{$v} = $TAINT;
            last if eval { `$echo 1` };
        while (my $v = $vars[0]) {
            local $ENV{$v} = $TAINT;
            last if eval { `$echo 1` };
-           last unless $@ =~ /^Insecure \$ENV{$v}/;
+           last unless $@ =~ /^Insecure \$ENV\{$v}/;
            shift @vars;
        }
        is("@vars", "");
            shift @vars;
        }
        is("@vars", "");
@@ -163,7 +163,7 @@ my $TEST = 'TEST';
        is(eval { `$echo 1` }, "1\n");
        $ENV{TERM} = 'e=mc2' . $TAINT;
        is(eval { `$echo 1` }, undef);
        is(eval { `$echo 1` }, "1\n");
        $ENV{TERM} = 'e=mc2' . $TAINT;
        is(eval { `$echo 1` }, undef);
-       like($@, qr/^Insecure \$ENV{TERM}/);
+       like($@, qr/^Insecure \$ENV\{TERM}/);
     }
 
     my $tmp;
     }
 
     my $tmp;
@@ -182,7 +182,7 @@ my $TEST = 'TEST';
 
        local $ENV{PATH} = $tmp;
        is(eval { `$echo 1` }, undef);
 
        local $ENV{PATH} = $tmp;
        is(eval { `$echo 1` }, undef);
-       like($@, qr/^Insecure directory in \$ENV{PATH}/);
+       like($@, qr/^Insecure directory in \$ENV\{PATH}/);
     }
 
     SKIP: {
     }
 
     SKIP: {
@@ -190,14 +190,14 @@ my $TEST = 'TEST';
 
        $ENV{'DCL$PATH'} = $TAINT;
        is(eval { `$echo 1` }, undef);
 
        $ENV{'DCL$PATH'} = $TAINT;
        is(eval { `$echo 1` }, undef);
-       like($@, qr/^Insecure \$ENV{DCL\$PATH}/);
+       like($@, qr/^Insecure \$ENV\{DCL\$PATH}/);
        SKIP: {
             skip q[can't find world-writeable directory to test DCL$PATH], 2
               unless $tmp;
 
            $ENV{'DCL$PATH'} = $tmp;
            is(eval { `$echo 1` }, undef);
        SKIP: {
             skip q[can't find world-writeable directory to test DCL$PATH], 2
               unless $tmp;
 
            $ENV{'DCL$PATH'} = $tmp;
            is(eval { `$echo 1` }, undef);
-           like($@, qr/^Insecure directory in \$ENV{DCL\$PATH}/);
+           like($@, qr/^Insecure directory in \$ENV\{DCL\$PATH}/);
        }
        $ENV{'DCL$PATH'} = '';
     }
        }
        $ENV{'DCL$PATH'} = '';
     }
@@ -296,25 +296,43 @@ my $TEST = 'TEST';
     is($res, 1,        "$desc: res value");
     is($one, 'a',      "$desc: \$1 value");
 
     is($res, 1,        "$desc: res value");
     is($one, 'a',      "$desc: \$1 value");
 
-    $desc = "match with pattern tainted via locale";
+  SKIP: {
+        skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale});
 
 
-    $s = 'abcd';
-    { use locale; $res = $s =~ /(\w+)/; $one = $1; }
-    isnt_tainted($s,   "$desc: s not tainted");
-    isnt_tainted($res, "$desc: res not tainted");
-    is_tainted($one,   "$desc: \$1 tainted");
-    is($res, 1,        "$desc: res value");
-    is($one, 'abcd',   "$desc: \$1 value");
+        $desc = "match with pattern tainted via locale";
 
 
-    $desc = "match /g with pattern tainted via locale";
-
-    $s = 'abcd';
-    { use locale; $res = $s =~ /(\w)/g; $one = $1; }
-    isnt_tainted($s,   "$desc: s not tainted");
-    isnt_tainted($res, "$desc: res not tainted");
-    is_tainted($one,   "$desc: \$1 tainted");
-    is($res, 1,        "$desc: res value");
-    is($one, 'a',      "$desc: \$1 value");
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ /(\w+)/; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        isnt_tainted($res, "$desc: res not tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 1,        "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+
+        $desc = "match /g with pattern tainted via locale";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ /(\w)/g; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        isnt_tainted($res, "$desc: res not tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 1,        "$desc: res value");
+        is($one, 'a',      "$desc: \$1 value");
+    }
 
     $desc = "match with pattern tainted, list cxt";
 
 
     $desc = "match with pattern tainted, list cxt";
 
@@ -339,27 +357,45 @@ my $TEST = 'TEST';
     is($res2,'b',      "$desc: res2 value");
     is($one, 'd',      "$desc: \$1 value");
 
     is($res2,'b',      "$desc: res2 value");
     is($one, 'd',      "$desc: \$1 value");
 
-    $desc = "match with pattern tainted via locale, list cxt";
-
-    $s = 'abcd';
-    { use locale; ($res) = $s =~ /(\w+)/; $one = $1; }
-    isnt_tainted($s,   "$desc: s not tainted");
-    is_tainted($res,   "$desc: res tainted");
-    is_tainted($one,   "$desc: \$1 tainted");
-    is($res, 'abcd',   "$desc: res value");
-    is($one, 'abcd',   "$desc: \$1 value");
+  SKIP: {
+        skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale});
 
 
-    $desc = "match /g with pattern tainted via locale, list cxt";
+        $desc = "match with pattern tainted via locale, list cxt";
 
 
-    $s = 'abcd';
-    { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; }
-    isnt_tainted($s,   "$desc: s not tainted");
-    is_tainted($res,   "$desc: res tainted");
-    is_tainted($res2,  "$desc: res2 tainted");
-    is_tainted($one,   "$desc: \$1 tainted");
-    is($res, 'a',      "$desc: res value");
-    is($res2,'b',      "$desc: res2 value");
-    is($one, 'd',      "$desc: \$1 value");
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            ($res) = $s =~ /(\w+)/; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 'abcd',   "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+
+        $desc = "match /g with pattern tainted via locale, list cxt";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            ($res, $res2) = $s =~ /(\w)/g; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($res2,  "$desc: res2 tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 'a',      "$desc: res value");
+        is($res2,'b',      "$desc: res2 value");
+        is($one, 'd',      "$desc: \$1 value");
+    }
 
     $desc = "substitution with string tainted";
 
 
     $desc = "substitution with string tainted";
 
@@ -481,38 +517,63 @@ my $TEST = 'TEST';
     is($res, 'xyz',    "$desc: res value");
     is($one, 'abcd',   "$desc: \$1 value");
 
     is($res, 'xyz',    "$desc: res value");
     is($one, 'abcd',   "$desc: \$1 value");
 
-    $desc = "substitution with pattern tainted via locale";
-
-    $s = 'abcd';
-    { use locale;  $res = $s =~ s/(\w+)/xyz/; $one = $1; }
-    is_tainted($s,     "$desc: s tainted");
-    isnt_tainted($res, "$desc: res not tainted");
-    is_tainted($one,   "$desc: \$1 tainted");
-    is($s,  'xyz',     "$desc: s value");
-    is($res, 1,        "$desc: res value");
-    is($one, 'abcd',   "$desc: \$1 value");
-
-    $desc = "substitution /g with pattern tainted via locale";
-
-    $s = 'abcd';
-    { use locale;  $res = $s =~ s/(\w)/x/g; $one = $1; }
-    is_tainted($s,     "$desc: s tainted");
-    is_tainted($res,   "$desc: res tainted");
-    is_tainted($one,   "$desc: \$1 tainted");
-    is($s,  'xxxx',    "$desc: s value");
-    is($res, 4,        "$desc: res value");
-    is($one, 'd',      "$desc: \$1 value");
+  SKIP: {
+        skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale});
 
 
-    $desc = "substitution /r with pattern tainted via locale";
+        $desc = "substitution with pattern tainted via locale";
 
 
-    $s = 'abcd';
-    { use locale;  $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
-    isnt_tainted($s,   "$desc: s not tainted");
-    is_tainted($res,   "$desc: res tainted");
-    is_tainted($one,   "$desc: \$1 tainted");
-    is($s,  'abcd',    "$desc: s value");
-    is($res, 'xyz',    "$desc: res value");
-    is($one, 'abcd',   "$desc: \$1 value");
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ s/(\w+)/xyz/; $one = $1;
+        }
+        is_tainted($s,     "$desc: s tainted");
+        isnt_tainted($res, "$desc: res not tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($s,  'xyz',     "$desc: s value");
+        is($res, 1,        "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+
+        $desc = "substitution /g with pattern tainted via locale";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ s/(\w)/x/g; $one = $1;
+        }
+        is_tainted($s,     "$desc: s tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($s,  'xxxx',    "$desc: s value");
+        is($res, 4,        "$desc: res value");
+        is($one, 'd',      "$desc: \$1 value");
+
+        $desc = "substitution /r with pattern tainted via locale";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ s/(\w+)/xyz/r; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($s,  'abcd',    "$desc: s value");
+        is($res, 'xyz',    "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+    }
 
     $desc = "substitution with replacement tainted";
 
 
     $desc = "substitution with replacement tainted";
 
@@ -561,7 +622,7 @@ my $TEST = 'TEST';
        $one = $1;
     }
     is_tainted($s,     "$desc: s tainted");
        $one = $1;
     }
     is_tainted($s,     "$desc: s tainted");
-    is_tainted($res,   "$desc: res tainted");
+    isnt_tainted($res, "$desc: res tainted");
     isnt_tainted($one, "$desc: \$1 not tainted");
     is($s,  '123',     "$desc: s value");
     is($res, 3,        "$desc: res value");
     isnt_tainted($one, "$desc: \$1 not tainted");
     is($s,  '123',     "$desc: s value");
     is($res, 3,        "$desc: res value");
@@ -652,25 +713,43 @@ my $TEST = 'TEST';
        is($res, 1,        "$desc: res value");
        is($one, 'a',      "$desc: \$1 value");
 
        is($res, 1,        "$desc: res value");
        is($one, 'a',      "$desc: \$1 value");
 
-       $desc = "use re 'taint': match with pattern tainted via locale";
-
-       $s = 'abcd';
-       { use locale; $res = $s =~ /(\w+)/; $one = $1; }
-       isnt_tainted($s,   "$desc: s not tainted");
-       isnt_tainted($res, "$desc: res not tainted");
-       is_tainted($one,   "$desc: \$1 tainted");
-       is($res, 1,        "$desc: res value");
-       is($one, 'abcd',   "$desc: \$1 value");
+  SKIP: {
+        skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale});
 
 
-       $desc = "use re 'taint': match /g with pattern tainted via locale";
+        $desc = "use re 'taint': match with pattern tainted via locale";
 
 
-       $s = 'abcd';
-       { use locale; $res = $s =~ /(\w)/g; $one = $1; }
-       isnt_tainted($s,   "$desc: s not tainted");
-       isnt_tainted($res, "$desc: res not tainted");
-       is_tainted($one,   "$desc: \$1 tainted");
-       is($res, 1,        "$desc: res value");
-       is($one, 'a',      "$desc: \$1 value");
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ /(\w+)/; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        isnt_tainted($res, "$desc: res not tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 1,        "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+
+        $desc = "use re 'taint': match /g with pattern tainted via locale";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ /(\w)/g; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        isnt_tainted($res, "$desc: res not tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 1,        "$desc: res value");
+        is($one, 'a',      "$desc: \$1 value");
+    }
 
        $desc = "use re 'taint': match with pattern tainted, list cxt";
 
 
        $desc = "use re 'taint': match with pattern tainted, list cxt";
 
@@ -695,27 +774,45 @@ my $TEST = 'TEST';
        is($res2,'b',      "$desc: res2 value");
        is($one, 'd',      "$desc: \$1 value");
 
        is($res2,'b',      "$desc: res2 value");
        is($one, 'd',      "$desc: \$1 value");
 
-       $desc = "use re 'taint': match with pattern tainted via locale, list cxt";
-
-       $s = 'abcd';
-       { use locale; ($res) = $s =~ /(\w+)/; $one = $1; }
-       isnt_tainted($s,   "$desc: s not tainted");
-       is_tainted($res,   "$desc: res tainted");
-       is_tainted($one,   "$desc: \$1 tainted");
-       is($res, 'abcd',   "$desc: res value");
-       is($one, 'abcd',   "$desc: \$1 value");
+  SKIP: {
+        skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale});
 
 
-       $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt";
+        $desc = "use re 'taint': match with pattern tainted via locale, list cxt";
 
 
-       $s = 'abcd';
-       { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; }
-       isnt_tainted($s,   "$desc: s not tainted");
-       is_tainted($res,   "$desc: res tainted");
-       is_tainted($res2,  "$desc: res2 tainted");
-       is_tainted($one,   "$desc: \$1 tainted");
-       is($res, 'a',      "$desc: res value");
-       is($res2,'b',      "$desc: res2 value");
-       is($one, 'd',      "$desc: \$1 value");
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            ($res) = $s =~ /(\w+)/; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 'abcd',   "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+
+        $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            ($res, $res2) = $s =~ /(\w)/g; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($res2,  "$desc: res2 tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($res, 'a',      "$desc: res value");
+        is($res2,'b',      "$desc: res2 value");
+        is($one, 'd',      "$desc: \$1 value");
+    }
 
        $desc = "use re 'taint': substitution with string tainted";
 
 
        $desc = "use re 'taint': substitution with string tainted";
 
@@ -838,38 +935,63 @@ my $TEST = 'TEST';
        is($res, 'xyz',    "$desc: res value");
        is($one, 'abcd',   "$desc: \$1 value");
 
        is($res, 'xyz',    "$desc: res value");
        is($one, 'abcd',   "$desc: \$1 value");
 
-       $desc = "use re 'taint': substitution with pattern tainted via locale";
-
-       $s = 'abcd';
-       { use locale;  $res = $s =~ s/(\w+)/xyz/; $one = $1; }
-       is_tainted($s,     "$desc: s tainted");
-       isnt_tainted($res, "$desc: res not tainted");
-       is_tainted($one,   "$desc: \$1 tainted");
-       is($s,  'xyz',     "$desc: s value");
-       is($res, 1,        "$desc: res value");
-       is($one, 'abcd',   "$desc: \$1 value");
+  SKIP: {
+        skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale});
 
 
-       $desc = "use re 'taint': substitution /g with pattern tainted via locale";
+        $desc = "use re 'taint': substitution with pattern tainted via locale";
 
 
-       $s = 'abcd';
-       { use locale;  $res = $s =~ s/(\w)/x/g; $one = $1; }
-       is_tainted($s,     "$desc: s tainted");
-       is_tainted($res,   "$desc: res tainted");
-       is_tainted($one,   "$desc: \$1 tainted");
-       is($s,  'xxxx',    "$desc: s value");
-       is($res, 4,        "$desc: res value");
-       is($one, 'd',      "$desc: \$1 value");
-
-       $desc = "use re 'taint': substitution /r with pattern tainted via locale";
-
-       $s = 'abcd';
-       { use locale;  $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
-       isnt_tainted($s,   "$desc: s not tainted");
-       is_tainted($res,   "$desc: res tainted");
-       is_tainted($one,   "$desc: \$1 tainted");
-       is($s,  'abcd',    "$desc: s value");
-       is($res, 'xyz',    "$desc: res value");
-       is($one, 'abcd',   "$desc: \$1 value");
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ s/(\w+)/xyz/; $one = $1;
+        }
+        is_tainted($s,     "$desc: s tainted");
+        isnt_tainted($res, "$desc: res not tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($s,  'xyz',     "$desc: s value");
+        is($res, 1,        "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+
+        $desc = "use re 'taint': substitution /g with pattern tainted via locale";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ s/(\w)/x/g; $one = $1;
+        }
+        is_tainted($s,     "$desc: s tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($s,  'xxxx',    "$desc: s value");
+        is($res, 4,        "$desc: res value");
+        is($one, 'd',      "$desc: \$1 value");
+
+        $desc = "use re 'taint': substitution /r with pattern tainted via locale";
+
+        $s = 'abcd';
+        {
+            BEGIN {
+                if($Config{d_setlocale}) {
+                    require locale; import locale;
+                }
+            }
+            $res = $s =~ s/(\w+)/xyz/r; $one = $1;
+        }
+        isnt_tainted($s,   "$desc: s not tainted");
+        is_tainted($res,   "$desc: res tainted");
+        is_tainted($one,   "$desc: \$1 tainted");
+        is($s,  'abcd',    "$desc: s value");
+        is($res, 'xyz',    "$desc: res value");
+        is($one, 'abcd',   "$desc: \$1 value");
+    }
 
        $desc = "use re 'taint': substitution with replacement tainted";
 
 
        $desc = "use re 'taint': substitution with replacement tainted";
 
@@ -918,7 +1040,7 @@ my $TEST = 'TEST';
            $one = $1;
        }
        is_tainted($s,     "$desc: s tainted");
            $one = $1;
        }
        is_tainted($s,     "$desc: s tainted");
-       is_tainted($res,   "$desc: res tainted");
+       isnt_tainted($res, "$desc: res tainted");
        isnt_tainted($one, "$desc: \$1 not tainted");
        is($s,  '123',     "$desc: s value");
        is($res, 3,        "$desc: res value");
        isnt_tainted($one, "$desc: \$1 not tainted");
        is($s,  '123',     "$desc: s value");
        is($res, 3,        "$desc: res value");
@@ -935,6 +1057,18 @@ my $TEST = 'TEST';
        is($s,   'abcd',   "$desc: s value");
        is($res, 'xyz',    "$desc: res value");
        is($one, 'abcd',   "$desc: \$1 value");
        is($s,   'abcd',   "$desc: s value");
        is($res, 'xyz',    "$desc: res value");
        is($one, 'abcd',   "$desc: \$1 value");
+
+        # [perl #121854] match taintedness became sticky
+        # when one match has a taintess result, subseqent matches
+        # using the same pattern shouldn't necessarily be tainted
+
+        {
+            my $f = sub { $_[0] =~ /(.*)/ or die; $1 };
+            $res = $f->($TAINT);
+            is_tainted($res,   "121854: res tainted");
+            $res = $f->("abc");
+            isnt_tainted($res,   "121854: res not tainted");
+        }
     }
 
     $foo = $1 if 'bar' =~ /(.+)$TAINT/;
     }
 
     $foo = $1 if 'bar' =~ /(.+)$TAINT/;
@@ -1311,7 +1445,12 @@ SKIP: {
         my $sent = "foobar";
         my $rcvd;
         my $size = 2000;
         my $sent = "foobar";
         my $rcvd;
         my $size = 2000;
-        my $id = shmget(IPC_PRIVATE, $size, S_IRWXU);
+        my $id;
+        eval {
+            local $SIG{SYS} = sub { die "SIGSYS caught\n" };
+            $id = shmget(IPC_PRIVATE, $size, S_IRWXU);
+            1;
+        } or do { chomp(my $msg = $@); skip "shmget: $msg", 1; };
 
         if (defined $id) {
             if (shmwrite($id, $sent, 0, 60)) {
 
         if (defined $id) {
             if (shmwrite($id, $sent, 0, 60)) {
@@ -1331,7 +1470,7 @@ SKIP: {
         skip "SysV shared memory operation failed", 1 unless 
           $rcvd eq $sent;
 
         skip "SysV shared memory operation failed", 1 unless 
           $rcvd eq $sent;
 
-        is_tainted($rcvd);
+        is_tainted($rcvd, "shmread");
     }
 
 
     }
 
 
@@ -1340,7 +1479,12 @@ SKIP: {
         skip "msg*() not available", 1 unless $Config{d_msg};
 
        no strict 'subs';
         skip "msg*() not available", 1 unless $Config{d_msg};
 
        no strict 'subs';
-       my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
+        my $id;
+        eval {
+            local $SIG{SYS} = sub { die "SIGSYS caught\n" };
+            $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
+            1;
+        } or do { chomp(my $msg = $@); skip "msgget: $msg", 1; };
 
        my $sent      = "message";
        my $type_sent = 1234;
 
        my $sent      = "message";
        my $type_sent = 1234;
@@ -1366,7 +1510,7 @@ SKIP: {
             skip "SysV message queue operation failed", 1
               unless $rcvd eq $sent && $type_sent == $type_rcvd;
 
             skip "SysV message queue operation failed", 1
               unless $rcvd eq $sent && $type_sent == $type_rcvd;
 
-           is_tainted($rcvd);
+           is_tainted($rcvd, "msgrcv");
        }
     }
 }
        }
     }
 }
@@ -1630,6 +1774,14 @@ TODO: {
     ($r = $TAINT) =~ /($TAINT)/;
     is_tainted($1);
 
     ($r = $TAINT) =~ /($TAINT)/;
     is_tainted($1);
 
+    {
+       use re 'eval'; # this shouldn't make any difference
+       ($r = $TAINT) =~ /($notaint)/;
+       isnt_tainted($1);
+       ($r = $TAINT) =~ /($TAINT)/;
+       is_tainted($1);
+    }
+
     #  [perl #24674]
     # accessing $^O  shoudn't taint it as a side-effect;
     # assigning tainted data to it is now an error
     #  [perl #24674]
     # accessing $^O  shoudn't taint it as a side-effect;
     # assigning tainted data to it is now an error
@@ -1867,18 +2019,21 @@ foreach my $ord (78, 163, 256) {
 }
 
 {
 }
 
 {
-    # 59998
-    sub cr { my $x = crypt($_[0], $_[1]); $x }
-    sub co { my $x = ~$_[0]; $x }
-    my ($a, $b);
-    $a = cr('hello', 'foo' . $TAINT);
-    $b = cr('hello', 'foo');
-    is_tainted($a,  "tainted crypt");
-    isnt_tainted($b, "untainted crypt");
-    $a = co('foo' . $TAINT);
-    $b = co('foo');
-    is_tainted($a,  "tainted complement");
-    isnt_tainted($b, "untainted complement");
+  SKIP: {
+      skip 'No crypt function, skipping crypt tests', 4 if(!$Config{d_crypt});
+      # 59998
+      sub cr { my $x = crypt($_[0], $_[1]); $x }
+      sub co { my $x = ~$_[0]; $x }
+      my ($a, $b);
+      $a = cr('hello', 'foo' . $TAINT);
+      $b = cr('hello', 'foo');
+      is_tainted($a,  "tainted crypt");
+      isnt_tainted($b, "untainted crypt");
+      $a = co('foo' . $TAINT);
+      $b = co('foo');
+      is_tainted($a,  "tainted complement");
+      isnt_tainted($b, "untainted complement");
+    }
 }
 
 {
 }
 
 {
@@ -2042,10 +2197,7 @@ end
     formline('@' .('<'*5) . ' | @*', 'hallo', 'welt');
     isnt_tainted($^A, "accumulator still untainted");
     formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt');
     formline('@' .('<'*5) . ' | @*', 'hallo', 'welt');
     isnt_tainted($^A, "accumulator still untainted");
     formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt');
-    TODO: {
-        local $::TODO = "get magic handled too late?";
-        is_tainted($^A, "the accumulator should be tainted already");
-    }
+    is_tainted($^A, "the accumulator should be tainted already");
     is_tainted($^A, "tainted formline picture makes a tainted accumulator");
 }
 
     is_tainted($^A, "tainted formline picture makes a tainted accumulator");
 }
 
@@ -2112,7 +2264,7 @@ end
     ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case");
     $prop = "IsA$TAINT";
     eval { "A" =~ /\p{$prop}/};
     ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case");
     $prop = "IsA$TAINT";
     eval { "A" =~ /\p{$prop}/};
-    like($@, qr/Insecure user-defined property \\p{main::IsA}/,
+    like($@, qr/Insecure user-defined property \\p\{main::IsA}/,
            "user-defined property: tainted case");
 }
 
            "user-defined property: tainted case");
 }
 
@@ -2132,6 +2284,7 @@ end
 {
     # Taintedness of values returned from given()
     use feature 'switch';
 {
     # Taintedness of values returned from given()
     use feature 'switch';
+    no warnings 'experimental::smartmatch';
 
     my @descriptions = ('when', 'given end', 'default');
 
 
     my @descriptions = ('when', 'given end', 'default');
 
@@ -2167,8 +2320,11 @@ end
 
 # Tainted values with smartmatch
 # [perl #93590] S_do_smartmatch stealing its own string buffers
 
 # Tainted values with smartmatch
 # [perl #93590] S_do_smartmatch stealing its own string buffers
+{
+no warnings 'experimental::smartmatch';
 ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]';
 ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]';
 ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]';
 ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]';
+}
 
 # Tainted values and ref()
 for(1,2) {
 
 # Tainted values and ref()
 for(1,2) {
@@ -2183,9 +2339,15 @@ pass("no death when TARG of ref is tainted");
     isnt_tainted $$, "PID not tainted when read in tainted expression";
 }
 
     isnt_tainted $$, "PID not tainted when read in tainted expression";
 }
 
-{
+SKIP: {
+    skip 'No locale testing without d_setlocale', 4 if(!$Config{d_setlocale});
+
     use feature 'fc';
     use feature 'fc';
-    use locale;
+    BEGIN {
+        if($Config{d_setlocale}) {
+            require locale; import locale;
+        }
+    }
     my ($latin1, $utf8) = ("\xDF") x 2;
     utf8::downgrade($latin1);
     utf8::upgrade($utf8);
     my ($latin1, $utf8) = ("\xDF") x 2;
     utf8::downgrade($latin1);
     utf8::upgrade($utf8);
@@ -2205,6 +2367,20 @@ pass("no death when TARG of ref is tainted");
   like($@, qr/^Test\n\t\.\.\.propagated at /, "error should be propagated");
 }
 
   like($@, qr/^Test\n\t\.\.\.propagated at /, "error should be propagated");
 }
 
+# tainted run-time (?{}) should die
+
+{
+    my $code = '(?{})' . $TAINT;
+    use re 'eval';
+    eval { "a" =~ /$code/ };
+    like($@, qr/Eval-group in insecure regular expression/, "tainted (?{})");
+}
+
+# reset() and tainted undef (?!)
+$::x = "foo";
+$_ = "$TAINT".reset "x";
+is eval { eval $::x.1 }, 1, 'reset does not taint undef';
+
 # This may bomb out with the alarm signal so keep it last
 SKIP: {
     skip "No alarm()"  unless $Config{d_alarm};
 # This may bomb out with the alarm signal so keep it last
 SKIP: {
     skip "No alarm()"  unless $Config{d_alarm};
Unnamed repository; edit this file 'description' to name the repository.