X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/05a1a0145d15cec87e1ea2fd2386895cc1658eb3..1738e041e86c4796d194727eae67369600abf920:/t/op/taint.t diff --git a/t/op/taint.t b/t/op/taint.t index 9cea740..aaf556a 100644 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -17,7 +17,7 @@ BEGIN { use strict; use Config; -plan tests => 794; +plan tests => 800; $| = 1; @@ -152,7 +152,7 @@ my $TEST = 'TEST'; 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", ""); @@ -163,7 +163,7 @@ my $TEST = 'TEST'; 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; @@ -182,7 +182,7 @@ my $TEST = 'TEST'; local $ENV{PATH} = $tmp; is(eval { `$echo 1` }, undef); - like($@, qr/^Insecure directory in \$ENV{PATH}/); + like($@, qr/^Insecure directory in \$ENV\{PATH}/); } SKIP: { @@ -190,14 +190,14 @@ my $TEST = 'TEST'; $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); - like($@, qr/^Insecure directory in \$ENV{DCL\$PATH}/); + like($@, qr/^Insecure directory in \$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"); - $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"; @@ -339,27 +357,45 @@ my $TEST = 'TEST'; 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"; @@ -481,38 +517,63 @@ my $TEST = 'TEST'; 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"; @@ -561,7 +622,7 @@ my $TEST = 'TEST'; $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"); @@ -652,25 +713,43 @@ my $TEST = 'TEST'; 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"; @@ -695,27 +774,45 @@ my $TEST = 'TEST'; 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"; @@ -838,38 +935,63 @@ my $TEST = 'TEST'; 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"; @@ -918,7 +1040,7 @@ my $TEST = 'TEST'; $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"); @@ -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"); + + # [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/; @@ -1311,7 +1445,12 @@ SKIP: { 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)) { @@ -1331,7 +1470,7 @@ SKIP: { 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'; - 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; @@ -1366,7 +1510,7 @@ SKIP: { 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); + { + 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 @@ -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'); - 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"); } @@ -2112,7 +2264,7 @@ end 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"); } @@ -2132,6 +2284,7 @@ end { # Taintedness of values returned from given() use feature 'switch'; + no warnings 'experimental::smartmatch'; 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 +{ +no warnings 'experimental::smartmatch'; ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]'; ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]'; +} # 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"; } -{ +SKIP: { + skip 'No locale testing without d_setlocale', 4 if(!$Config{d_setlocale}); + 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); @@ -2205,6 +2367,20 @@ pass("no death when TARG of ref is tainted"); 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};