BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ require './loc_tools.pl';
+ set_up_inc('../lib');
}
use strict;
use Config;
-use File::Spec::Functions;
-BEGIN { require './test.pl'; }
-plan tests => 706;
+plan tests => 808;
$| = 1;
}
# How to identify taint when you see it
-sub any_tainted (@) {
- not eval { join("",@_), kill 0; 1 };
-}
sub tainted ($) {
- any_tainted @_;
-}
-sub all_tainted (@) {
- for (@_) { return 0 unless tainted $_ }
- 1;
+ local $@; # Don't pollute caller's value.
+ not eval { join("",@_), kill 0; 1 };
}
sub is_tainted {
my $thing = shift;
local $::Level = $::Level + 1;
- ok(any_tainted($thing), @_);
+ ok(tainted($thing), @_);
}
sub isnt_tainted {
my $thing = shift;
local $::Level = $::Level + 1;
- ok(!any_tainted($thing), @_);
+ ok(!tainted($thing), @_);
+}
+
+sub violates_taint {
+ my ($code, $what, $desc) = @_;
+ $desc //= $what;
+ local $::Level = $::Level + 1;
+ is(eval { $code->(); }, undef, $desc);
+ like($@, qr/^Insecure dependency in $what while running with -T switch/);
}
# We need an external program to call.
my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$"));
END { unlink $ECHO }
-open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
-print PROG 'print "@ARGV\n"', "\n";
-close PROG;
+open my $fh, '>', $ECHO or die "Can't create $ECHO: $!";
+print $fh 'print "@ARGV\n"', "\n";
+close $fh;
my $echo = "$Invoke_Perl $ECHO";
-my $TEST = catfile(curdir(), 'TEST');
+my $TEST = 'TEST';
# First, let's make sure that Perl is checking the dangerous
# environment variables. Maybe they aren't set yet, so we'll
{
$ENV{'DCL$PATH'} = '' if $Is_VMS;
- if ($Is_MSWin32 && $Config{ccname} =~ /bcc32/ && ! -f 'cc3250mt.dll') {
- my $bcc_dir;
- foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
- if (-f "$dir/cc3250mt.dll") {
- $bcc_dir = $dir and last;
- }
- }
- if (defined $bcc_dir) {
- require File::Copy;
- File::Copy::copy("$bcc_dir/cc3250mt.dll", '.') or
- die "$0: failed to copy cc3250mt.dll: $!\n";
- eval q{
- END { unlink "cc3250mt.dll" }
- };
- }
- }
$ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : '';
delete @ENV{@MoreEnv};
$ENV{TERM} = 'dumb';
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", "");
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;
local $ENV{PATH} = $tmp;
is(eval { `$echo 1` }, undef);
- like($@, qr/^Insecure directory in \$ENV{PATH}/);
+ # Message can be different depending on whether echo
+ # is a builtin or not
+ like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH}/);
}
SKIP: {
skip "This is not VMS", 4 unless $Is_VMS;
$ENV{'DCL$PATH'} = $TAINT;
- is(eval { `$echo 1` }, '');
- like($@, qr/^Insecure \$ENV{DCL\$PATH}/);
+ is(eval { `$echo 1` }, undef);
+ 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` }, '');
- like($@, qr/^Insecure directory in \$ENV{DCL\$PATH}/);
+ is(eval { `$echo 1` }, undef);
+ like($@, qr/^Insecure directory in \$ENV\{DCL\$PATH}/);
}
$ENV{'DCL$PATH'} = '';
}
is_tainted($foo);
my @list = 1..10;
- ok(not any_tainted @list);
+ isnt_tainted($_) foreach @list;
taint_these @list[1,3,5,7,9];
- ok(any_tainted @list);
- ok(all_tainted @list[1,3,5,7,9]);
- ok(not any_tainted @list[0,2,4,6,8]);
+ is_tainted($_) foreach @list[1,3,5,7,9];
+ isnt_tainted($_) foreach @list[0,2,4,6,8];
($foo) = $foo =~ /(.+)/;
isnt_tainted($foo);
is($res, 1, "$desc: res value");
is($one, 'a', "$desc: \$1 value");
- $desc = "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 'Locales not available', 10 unless locales_enabled('LC_CTYPE');
- $desc = "match /g with pattern tainted via locale";
+ $desc = "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';
+ {
+ 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 /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");
+ }
$desc = "match with pattern tainted, list cxt";
is($res2,'b', "$desc: res2 value");
is($one, 'd', "$desc: \$1 value");
- $desc = "match with pattern tainted via locale, list cxt";
+ SKIP: {
+ skip 'Locales not available', 12 unless locales_enabled('LC_CTYPE');
- $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");
-
- $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';
+ {
+ 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");
+
+ $desc = "match /g 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");
+ }
$desc = "substitution with string tainted";
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 'Locales not available', 18 unless locales_enabled('LC_CTYPE');
- $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';
+ {
+ 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");
+
+ $desc = "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");
+ }
$desc = "substitution with replacement 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");
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 'Locales not available', 10 unless locales_enabled('LC_CTYPE');
- $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';
+ {
+ 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 = "use re 'taint': 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");
+ }
$desc = "use re 'taint': match with pattern tainted, list cxt";
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 'Locales not available', 12 unless locales_enabled('LC_CTYPE');
- $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';
+ {
+ 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");
+
+ $desc = "use re 'taint': match /g 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");
+ }
$desc = "use re 'taint': substitution with string tainted";
is($res, 'xyz', "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
- $desc = "use re 'taint': substitution with pattern tainted via locale";
+ SKIP: {
+ skip 'Locales not available', 18 unless locales_enabled('LC_CTYPE');
- $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 = "use re 'taint': 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");
+ $desc = "use re 'taint': substitution with pattern tainted via locale";
- $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';
+ {
+ 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 = "use re 'taint': 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");
+
+ $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");
+ }
$desc = "use re 'taint': substitution with replacement 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");
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/;
# always get some, so we'll run another process with some.
SKIP: {
my $arg = tempfile();
- open PROG, "> $arg" or die "Can't create $arg: $!";
- print PROG q{
+ open $fh, '>', $arg or die "Can't create $arg: $!";
+ print $fh q{
eval { join('', @ARGV), kill 0 };
exit 0 if $@ =~ /^Insecure dependency/;
print "# Oops: \$@ was [$@]\n";
exit 1;
};
- close PROG;
+ close $fh or die "Can't close $arg: $!";
print `$Invoke_Perl "-T" $arg and some suspect arguments`;
is($?, 0, "Exited with status $?");
unlink $arg;
# Reading from a file should be tainted
{
- ok(open FILE, $TEST) or diag("Couldn't open '$TEST': $!");
+ ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!");
my $block;
- sysread(FILE, $block, 100);
- my $line = <FILE>;
- close FILE;
+ sysread($fh, $block, 100);
+ my $line = <$fh>;
+ close $fh;
is_tainted($block);
is_tainted($line);
}
# Certain system variables should be tainted
{
- ok(all_tainted $^X, $0);
+ is_tainted($^X);
+ is_tainted($0);
}
# Results of matching should all be untainted
is_tainted($foo);
$foo =~ /def/;
- ok(not any_tainted $`, $&, $');
+ isnt_tainted($`);
+ isnt_tainted($&);
+ isnt_tainted($');
$foo =~ /(...)(...)(...)/;
- ok(not any_tainted $1, $2, $3, $+);
+ isnt_tainted($1);
+ isnt_tainted($2);
+ isnt_tainted($3);
+ isnt_tainted($+);
my @bar = $foo =~ /(...)(...)(...)/;
- ok(not any_tainted @bar);
+ isnt_tainted($_) foreach @bar;
is_tainted($foo); # $foo should still be tainted!
is($foo, "abcdefghi");
# Operations which affect files can't use tainted data.
{
- is(eval { chmod 0, $TAINT }, undef, 'chmod');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { chmod 0, $TAINT }, 'chmod');
SKIP: {
skip "truncate() is not available", 2 unless $Config{d_truncate};
- is(eval { truncate 'NoSuChFiLe', $TAINT0 }, undef, 'truncate');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate');
}
- is(eval { rename '', $TAINT }, undef, 'rename');
- like($@, qr/^Insecure dependency/);
-
- is(eval { unlink $TAINT }, undef, 'unlink');
- like($@, qr/^Insecure dependency/);
-
- is(eval { utime $TAINT }, undef, 'utime');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { rename '', $TAINT }, 'rename');
+ violates_taint(sub { unlink $TAINT }, 'unlink');
+ violates_taint(sub { utime $TAINT }, 'utime');
SKIP: {
skip "chown() is not available", 2 unless $Config{d_chown};
- is(eval { chown -1, -1, $TAINT }, undef, 'chown');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { chown -1, -1, $TAINT }, 'chown');
}
SKIP: {
skip "link() is not available", 2 unless $Config{d_link};
- is(eval { link $TAINT, '' }, undef, 'link');
- like($@, qr/^Insecure dependency/);
+violates_taint(sub { link $TAINT, '' }, 'link');
}
SKIP: {
skip "symlink() is not available", 2 unless $Config{d_symlink};
- is(eval { symlink $TAINT, '' }, undef, 'symlink');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { symlink $TAINT, '' }, 'symlink');
}
}
# Operations which affect directories can't use tainted data.
{
- is(eval { mkdir "foo".$TAINT, 0755 . $TAINT0 }, undef, 'mkdir');
- like($@, qr/^Insecure dependency/);
-
- is(eval { rmdir $TAINT }, undef, 'rmdir');
- like($@, qr/^Insecure dependency/);
-
- is(eval { chdir "foo".$TAINT }, undef, 'chdir');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { mkdir "foo".$TAINT, 0755 . $TAINT0 }, 'mkdir');
+ violates_taint(sub { rmdir $TAINT }, 'rmdir');
+ violates_taint(sub { chdir "foo".$TAINT }, 'chdir');
SKIP: {
skip "chroot() is not available", 2 unless $Config{d_chroot};
- is(eval { chroot $TAINT }, undef, 'chroot');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { chroot $TAINT }, 'chroot');
}
}
# Some operations using files can't use tainted data.
{
my $foo = "imaginary library" . $TAINT;
- is(eval { require $foo }, undef, 'require');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { require $foo }, 'require');
my $filename = tempfile(); # NB: $filename isn't tainted!
$foo = $filename . $TAINT;
unlink $filename; # in any case
is(eval { open FOO, $foo }, undef, 'open for read');
- is($@, ''); # NB: This should be allowed
+ is($@, ''); # NB: This should be allowed
+ is(eval { open my $fh, , '<', $foo }, undef, 'open for read');
+ is($@, ''); # NB: This should be allowed
# Try first new style but allow also old style.
# We do not want the whole taint.t to fail
$! == 2 || # File not found
($Is_Dos && $! == 22));
- is(eval { open FOO, "> $foo" }, undef, 'open for write');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { open FOO, "> $foo" }, 'open', 'open for write');
+ violates_taint(sub { open my $fh, '>', $foo }, 'open', 'open for write');
}
# Commands to the system can't use tainted data
my $foo = $TAINT;
SKIP: {
- skip "open('|') is not available", 4 if $^O eq 'amigaos';
+ skip "open('|') is not available", 8 if $^O eq 'amigaos';
- is(eval { open FOO, "| x$foo" }, undef, 'popen to');
- like($@, qr/^Insecure dependency/);
-
- is(eval { open FOO, "x$foo |" }, undef, 'popen from');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { open FOO, "| x$foo" }, 'piped open', 'popen to');
+ violates_taint(sub { open FOO, "x$foo |" }, 'piped open', 'popen from');
+ violates_taint(sub { open my $fh, '|-', "x$foo" }, 'piped open', 'popen to');
+ violates_taint(sub { open my $fh, '-|', "x$foo" }, 'piped open', 'popen from');
}
- is(eval { exec $TAINT }, undef, 'exec');
- like($@, qr/^Insecure dependency/);
-
- is(eval { system $TAINT }, undef, 'system');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { exec $TAINT }, 'exec');
+ violates_taint(sub { system $TAINT }, 'system');
$foo = "*";
taint_these $foo;
- is(eval { `$echo 1$foo` }, undef, 'backticks');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { `$echo 1$foo` }, '``', 'backticks');
SKIP: {
# wildcard expansion doesn't invoke shell on VMS, so is safe
# Operations which affect processes can't use tainted data.
{
- is(eval { kill 0, $TAINT }, undef, 'kill');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { kill 0, $TAINT }, 'kill');
SKIP: {
skip "setpgrp() is not available", 2 unless $Config{d_setpgrp};
- is(eval { setpgrp 0, $TAINT0 }, undef, 'setpgrp');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { setpgrp 0, $TAINT0 }, 'setpgrp');
}
SKIP: {
skip "setpriority() is not available", 2 unless $Config{d_setprior};
- is(eval { setpriority 0, $TAINT0, $TAINT0 }, undef, 'setpriority');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority');
}
}
SKIP: {
skip "syscall() is not available", 2 unless $Config{d_syscall};
- is(eval { syscall $TAINT }, undef, 'syscall');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { syscall $TAINT }, 'syscall');
}
{
local *FOO;
my $temp = tempfile();
ok(open FOO, "> $temp") or diag("Couldn't open $temp for write: $!");
+ violates_taint(sub { ioctl FOO, $TAINT0, $foo }, 'ioctl');
- is(eval { ioctl FOO, $TAINT0, $foo }, undef, 'ioctl');
- like($@, qr/^Insecure dependency/);
+ my $temp2 = tempfile();
+ ok(open my $fh, '>', $temp2) or diag("Couldn't open $temp2 for write: $!");
+ violates_taint(sub { ioctl $fh, $TAINT0, $foo }, 'ioctl');
SKIP: {
- skip "fcntl() is not available", 2 unless $Config{d_fcntl};
+ skip "fcntl() is not available", 4 unless $Config{d_fcntl};
- is(eval { fcntl FOO, $TAINT0, $foo }, undef, 'fcntl');
- like($@, qr/^Insecure dependency/);
+ violates_taint(sub { fcntl FOO, $TAINT0, $foo }, 'fcntl');
+ violates_taint(sub { fcntl $fh, $TAINT0, $foo }, 'fcntl');
}
close FOO;
{
my $foo = $TAINT0;
my $bar = $foo;
- ok(all_tainted $foo, $bar);
+ is_tainted($foo);
+ is_tainted($bar);
is_tainted($foo = $bar);
is_tainted($bar = $bar);
is_tainted($bar += $bar);
# pretty hard to imagine not
skip "readdir() is not available", 1 unless $Config{d_readdir};
- local(*D);
- opendir(D, "op") or die "opendir: $!\n";
- my $readdir = readdir(D);
+ opendir my $dh, "op" or die "opendir: $!\n";
+ my $readdir = readdir $dh;
is_tainted($readdir);
- closedir(D);
+ closedir $dh;
}
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)) {
skip "SysV shared memory operation failed", 1 unless
$rcvd eq $sent;
- is_tainted($rcvd);
+ is_tainted($rcvd, "shmread");
}
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;
skip "SysV message queue operation failed", 1
unless $rcvd eq $sent && $type_sent == $type_rcvd;
- is_tainted($rcvd);
+ is_tainted($rcvd, "msgrcv");
}
}
}
{
# bug id 20001004.006
- open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
+ open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ;
local $/;
- my $a = <IN>;
- my $b = <IN>;
+ my $a = <$fh>;
+ my $b = <$fh>;
is_tainted($a);
is_tainted($b);
is($b, undef);
-
- close IN;
}
{
# bug id 20001004.007
- open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
- my $a = <IN>;
+ open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ;
+ my $a = <$fh>;
my $c = { a => 42,
b => $a };
isnt_tainted($e->{b});
is_tainted($e->{b}->{c});
isnt_tainted($e->{b}->{d});
-
- close IN;
}
{
}
SKIP: {
- skip "no Fcntl", 18 unless $has_fcntl;
+ skip "no Fcntl", 36 unless $has_fcntl;
my $foo = tempfile();
my $evil = $foo . $TAINT;
- eval { sysopen(my $ro, $evil, &O_RDONLY) };
- unlike($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $wo, $evil, &O_WRONLY) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $rw, $evil, &O_RDWR) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $ap, $evil, &O_APPEND) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $cr, $evil, &O_CREAT) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $tr, $evil, &O_TRUNC) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) };
- unlike($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) };
- unlike($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) };
- like($@, qr/^Insecure dependency/);
-
- eval { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) };
- like($@, qr/^Insecure dependency/);
+ is(eval { sysopen(my $ro, $evil, &O_RDONLY) }, undef);
+ is($@, '');
+
+ violates_taint(sub { sysopen(my $wo, $evil, &O_WRONLY) }, 'sysopen');
+ violates_taint(sub { sysopen(my $rw, $evil, &O_RDWR) }, 'sysopen');
+ violates_taint(sub { sysopen(my $ap, $evil, &O_APPEND) }, 'sysopen');
+ violates_taint(sub { sysopen(my $cr, $evil, &O_CREAT) }, 'sysopen');
+ violates_taint(sub { sysopen(my $tr, $evil, &O_TRUNC) }, 'sysopen');
+
+ is(eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) }, undef);
+ is($@, '');
+
+ violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) }, 'sysopen');
+ is(eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) }, undef);
+ is($@, '');
+
+ violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) }, 'sysopen');
+ violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) }, 'sysopen');
}
}
}
-ok( ${^TAINT} == 1, '$^TAINT is on' );
+is(${^TAINT}, 1, '$^TAINT is on');
eval { ${^TAINT} = 0 };
-ok( ${^TAINT}, '$^TAINT is not assignable' );
-ok( $@ =~ /^Modification of a read-only value attempted/,
- 'Assigning to ${^TAINT} fails' );
+is(${^TAINT}, 1, '$^TAINT is not assignable');
+like($@, qr/^Modification of a read-only value attempted/,
+ 'Assigning to ${^TAINT} fails');
{
# bug 20011111.105
if $Is_VMS;
# bug 20020208.005 plus some single arg exec/system extras
- my $err = qr/^Insecure dependency/ ;
- is(eval { exec $TAINT, $TAINT }, undef, 'exec');
- like($@, $err);
- is(eval { exec $TAINT $TAINT }, undef, 'exec');
- like($@, $err);
- is(eval { exec $TAINT $TAINT, $TAINT }, undef, 'exec');
- like($@, $err);
- is(eval { exec $TAINT 'notaint' }, undef, 'exec');
- like($@, $err);
- is(eval { exec {'notaint'} $TAINT }, undef, 'exec');
- like($@, $err);
-
- is(eval { system $TAINT, $TAINT }, undef, 'system');
- like($@, $err);
- is(eval { system $TAINT $TAINT }, undef, 'system');
- like($@, $err);
- is(eval { system $TAINT $TAINT, $TAINT }, undef, 'system');
- like($@, $err);
- is(eval { system $TAINT 'notaint' }, undef, 'system');
- like($@, $err);
- is(eval { system {'notaint'} $TAINT }, undef, 'system');
- like($@, $err);
+ violates_taint(sub { exec $TAINT, $TAINT }, 'exec');
+ violates_taint(sub { exec $TAINT $TAINT }, 'exec');
+ violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec');
+ violates_taint(sub { exec $TAINT 'notaint' }, 'exec');
+ violates_taint(sub { exec {'notaint'} $TAINT }, 'exec');
+
+ violates_taint(sub { system $TAINT, $TAINT }, 'system');
+ violates_taint(sub { system $TAINT $TAINT }, 'system');
+ violates_taint(sub { system $TAINT $TAINT, $TAINT }, 'system');
+ violates_taint(sub { system $TAINT 'notaint' }, 'system');
+ violates_taint(sub { system {'notaint'} $TAINT }, 'system');
eval {
no warnings;
($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
if ( $foo eq '' ) {
}
elsif ( $foo =~ /([$valid_chars]+)/o ) {
- isnt_tainted($1);
+ isnt_tainted($1);
+ isnt($1, undef);
}
if ( $foo eq '' ) {
}
elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) {
- ok(not any_tainted @bar);
+ isnt_tainted($bar[0]);
+ is(scalar @bar, 1);
}
}
{
# tests for tainted format in s?printf
- eval { printf($TAINT . "# %s\n", "foo") };
- like($@, qr/^Insecure dependency in printf/, q/printf doesn't like tainted formats/);
+ my $fmt = $TAINT . "# %s\n";
+ violates_taint(sub { printf($fmt, "foo") }, 'printf',
+ q/printf doesn't like tainted formats/);
+ violates_taint(sub { printf($TAINT . "# %s\n", "foo") }, 'printf',
+ q/printf doesn't like tainted format expressions/);
eval { printf("# %s\n", $TAINT . "foo") };
- ok(!$@, q/printf accepts other tainted args/);
- eval { sprintf($TAINT . "# %s\n", "foo") };
- like($@, qr/^Insecure dependency in sprintf/, q/sprintf doesn't like tainted formats/);
+ is($@, '', q/printf accepts other tainted args/);
+ violates_taint(sub { sprintf($fmt, "foo") }, 'sprintf',
+ q/sprintf doesn't like tainted formats/);
+ violates_taint(sub { sprintf($TAINT . "# %s\n", "foo") }, 'sprintf',
+ q/sprintf doesn't like tainted format expressions/);
eval { sprintf("# %s\n", $TAINT . "foo") };
- ok(!$@, q/sprintf accepts other tainted args/);
+ is($@, '', q/sprintf accepts other tainted args/);
}
{
like ($@, qr/^Insecure dependency in eval/);
# Rather nice code to get a tainted undef by from Rick Delaney
- open FH, "test.pl" or die $!;
- seek FH, 0, 2 or die $!;
- $tainted = <FH>;
+ open my $fh, "test.pl" or die $!;
+ seek $fh, 0, 2 or die $!;
+ $tainted = <$fh>;
eval 'eval $tainted';
like ($@, qr/^Insecure dependency in eval/);
}
{
- # 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 {
+ # On platforms implementing FIPS mode, using a weak algorithm
+ # (including the default triple-DES algorithm) causes crypt(3) to
+ # return a null pointer, which Perl converts into undef. We assume
+ # for now that all such platforms support glibc-style selection of
+ # a different hashing algorithm.
+ # glibc supports MD5, but OpenBSD only supports Blowfish.
+ my $alg = ''; # Use default algorithm
+ if ( !defined(crypt("ab", $alg."cd")) ) {
+ $alg = '$5$'; # Try SHA-256
+ }
+ if ( !defined(crypt("ab", $alg."cd")) ) {
+ $alg = '$2b$12$FPWWO2RJ3CK4FINTw0Hi'; # Try Blowfish
+ }
+ if ( !defined(crypt("ab", $alg."cd")) ) {
+ $alg = ''; # Nothing worked. Back to default
+ }
+ my $x = crypt($_[0], $alg . $_[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");
+ }
}
{
}
# Bug RT #45167 the return value of sprintf sometimes wasn't tainted
-# when the args were tainted. This only occured on the first use of
+# when the args were tainted. This only occurred on the first use of
# sprintf; after that, its TARG has taint magic attached, so setmagic
# at the end works. That's why there are multiple sprintf's below, rather
# than just one wrapped in an inner loop. Also, any plaintext between
-# fprmat entires would correctly cause tainting to get set. so test with
+# format entries would correctly cause tainting to get set. so test with
# "%s%s" rather than eg "%s %s".
{
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");
}
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");
}
+{
+ # [perl #87336] lc/uc(first) failing to taint the returned string
+ my $source = "foo$TAINT";
+ my $dest = lc $source;
+ is_tainted $dest, "lc(tainted) taints its return value";
+ $dest = lcfirst $source;
+ is_tainted $dest, "lcfirst(tainted) taints its return value";
+ $dest = uc $source;
+ is_tainted $dest, "uc(tainted) taints its return value";
+ $dest = ucfirst $source;
+ is_tainted $dest, "ucfirst(tainted) taints its return value";
+}
+
+{
+ # Taintedness of values returned from given()
+ use feature 'switch';
+ no warnings 'experimental::smartmatch';
+
+ my @descriptions = ('when', 'given end', 'default');
+
+ for (qw<x y z>) {
+ my $letter = "$_$TAINT";
+
+ my $desc = "tainted value returned from " . shift(@descriptions);
+
+ my $res = do {
+ given ($_) {
+ when ('x') { $letter }
+ when ('y') { goto leavegiven }
+ default { $letter }
+ leavegiven: $letter
+ }
+ };
+ is $res, $letter, "$desc is correct";
+ is_tainted $res, "$desc stays tainted";
+ }
+}
+
+
+# tainted constants and index()
+# RT 64804; http://bugs.debian.org/291450
+{
+ ok(tainted $old_env_path, "initial taintedness");
+ BEGIN { no strict 'refs'; my $v = $old_env_path; *{"::C"} = sub () { $v }; }
+ ok(tainted C, "constant is tainted properly");
+ ok(!tainted "", "tainting not broken yet");
+ index(undef, C);
+ ok(!tainted "", "tainting still works after index() of the constant");
+}
+
+# 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) {
+ my $x = bless \"M$TAINT", ref(bless[], "main");
+}
+pass("no death when TARG of ref is tainted");
+
+# $$ should not be tainted by being read in a tainted expression.
+{
+ isnt_tainted $$, "PID not tainted initially";
+ my $x = $ENV{PATH}.$$;
+ isnt_tainted $$, "PID not tainted when read in tainted expression";
+}
+
+SKIP: {
+ skip 'Locales not available', 4 unless locales_enabled('LC_CTYPE');
+
+ use feature 'fc';
+ use locale;
+ my ($latin1, $utf8) = ("\xDF") x 2;
+ utf8::downgrade($latin1);
+ utf8::upgrade($utf8);
+
+ is_tainted fc($latin1), "under locale, lc(latin1) taints the result";
+ is_tainted fc($utf8), "under locale, lc(utf8) taints the result";
+
+ is_tainted "\F$latin1", "under locale, \\Flatin1 taints the result";
+ is_tainted "\F$utf8", "under locale, \\Futf8 taints the result";
+}
+
+{ # 111654
+ eval {
+ eval { die "Test\n".substr($ENV{PATH}, 0, 0); };
+ die;
+ };
+ 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';
+
+# [perl #122669]
+{
+ # See the comment above the first formline test.
+ local $ENV{PATH} = $ENV{PATH};
+ $ENV{PATH} = $old_env_path if $Is_MSWin32;
+ is runperl(
+ switches => [ '-T' ],
+ prog => 'use constant K=>$^X; 0 if K; BEGIN{} use strict; '
+ .'print 122669, qq-\n-',
+ stderr => 1,
+ ), "122669\n",
+ 'tainted constant as logop condition should not prevent "use"';
+}
+
+# optimised SETi etc need to handle tainting
+
+{
+ my ($i1, $i2, $i3) = (1, 1, 1);
+ my ($n1, $n2, $n3) = (1.1, 1.1, 1.1);
+ my $tn = $TAINT0 + 1.1;
+
+ $i1 = $TAINT0 + 2;
+ is_tainted $i1, "+ SETi";
+ $i2 = $TAINT0 - 2;
+ is_tainted $i2, "- SETi";
+ $i3 = $TAINT0 * 2;
+ is_tainted $i3, "* SETi";
+
+ $n1 = $tn + 2.2;
+ is_tainted $n1, "+ SETn";
+ $n2 = $tn - 2.2;
+ is_tainted $n2, "- SETn";
+ $n3 = $tn * 2.2;
+ is_tainted $n3, "* SETn";
+}
+
+# check that localizing something with get magic (e.g. taint) doesn't
+# upgrade pIOK to IOK
+
+{
+ local our $x = 1.1 + $TAINT0; # $x should be NOK
+ my $ix = int($x); # now NOK, pIOK
+ {
+ local $x = 0;
+ }
+ my $x1 = $x * 1;
+ isnt($x, 1); # it should be 1.1, not 1
+}
+
+
# This may bomb out with the alarm signal so keep it last
SKIP: {
skip "No alarm()" unless $Config{d_alarm};
https://perl5.git.perl.org / perl5.git / blobdiff