BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no re");
+ set_up_inc('../lib');
+ require './loc_tools.pl';
}
use strict;
use Config;
-plan tests => 795;
+plan tests => 1052;
$| = 1;
-use vars qw($ipcsysv); # did we manage to load IPC::SysV?
+my $ipcsysv; # did we manage to load IPC::SysV?
my ($old_env_path, $old_env_dcl_path, $old_env_term);
BEGIN {
# Sources of taint:
# The empty tainted value, for tainting strings
my $TAINT = substr($^X, 0, 0);
+# A tainted non-empty string
+my $TAINTXYZ = "xyz".$TAINT;
# A tainted zero, useful for tainting numbers
my $TAINT0;
{
}
# We need an external program to call.
-my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$"));
+my $ECHO = ($Is_MSWin32 ? ".\\tmpecho$$" : ($Is_NetWare ? "tmpecho$$" : "./tmpecho$$"));
END { unlink $ECHO }
open my $fh, '>', $ECHO or die "Can't create $ECHO: $!";
print $fh 'print "@ARGV\n"', "\n";
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\}/);
+ }
+
+ # Relative paths in $ENV{PATH} are always implicitly tainted.
+ SKIP: {
+ skip "Do these work on VMS?", 4 if $Is_VMS;
+ skip "Not applicable to DOSish systems", 4 if! $tmp;
+
+ local $ENV{PATH} = '.';
+ is(eval { `$echo 1` }, undef);
+ like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/);
+
+ # Backslash should not fool perl into thinking that this is one
+ # path.
+ local $ENV{PATH} = '/\:.';
+ is(eval { `$echo 1` }, undef);
+ like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/);
}
SKIP: {
$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'} = '';
}
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";
-
- $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 = "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";
+ SKIP: {
+ skip 'Locales not available', 18 unless locales_enabled('LC_CTYPE');
+
+ $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");
+
+ $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 partial replacement tainted";
$s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; }
+ $res = $s =~ s/(.+)/xyz$TAINT/;
+ $one = $1;
is_tainted($s, "$desc: s tainted");
isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
+ isnt_tainted($one, "$desc: \$1 not 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";
+ $desc = "substitution /g with partial replacement tainted";
$s = 'abcd';
- { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; }
+ $res = $s =~ s/(.)/x$TAINT/g;
+ $one = $1;
is_tainted($s, "$desc: s tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not 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";
+ $desc = "substitution /ge with partial replacement tainted";
+
+ $s = 'abc';
+ {
+ my $i = 0;
+ my $j;
+ $res = $s =~ s{(.)}{
+ $j = $i; # make sure code not tainted
+ $one = $1;
+ isnt_tainted($j, "$desc: code not tainted within /e");
+ $i++;
+ if ($i == 1) {
+ isnt_tainted($s, "$desc: s not tainted loop 1");
+ }
+ else {
+ is_tainted($s, "$desc: s tainted loop $i");
+ }
+ isnt_tainted($one, "$desc: \$1 not tainted within /e");
+ $i.$TAINT;
+ }ge;
+ $one = $1;
+ }
+ is_tainted($s, "$desc: s 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($one, 'c', "$desc: \$1 value");
+
+ $desc = "substitution /r with partial replacement tainted";
$s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
+ $res = $s =~ s/(.+)/xyz$TAINT/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");
+ isnt_tainted($one, "$desc: \$1 not 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 whole replacement tainted";
$s = 'abcd';
- $res = $s =~ s/(.+)/xyz$TAINT/;
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
$one = $1;
is_tainted($s, "$desc: s tainted");
isnt_tainted($res, "$desc: res not tainted");
is($res, 1, "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
- $desc = "substitution /g with replacement tainted";
+ $desc = "substitution /g with whole replacement tainted";
$s = 'abcd';
- $res = $s =~ s/(.)/x$TAINT/g;
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
$one = $1;
is_tainted($s, "$desc: s tainted");
isnt_tainted($res, "$desc: res not tainted");
isnt_tainted($one, "$desc: \$1 not tainted");
- is($s, 'xxxx', "$desc: s value");
+ is($s, 'xyz' x 4, "$desc: s value");
is($res, 4, "$desc: res value");
is($one, 'd', "$desc: \$1 value");
- $desc = "substitution /ge with replacement tainted";
+ $desc = "substitution /ge with whole replacement tainted";
$s = 'abc';
{
is_tainted($s, "$desc: s tainted loop $i");
}
isnt_tainted($one, "$desc: \$1 not tainted within /e");
- $i.$TAINT;
+ $TAINTXYZ;
}ge;
$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($s, 'xyz' x 3, "$desc: s value");
is($res, 3, "$desc: res value");
is($one, 'c', "$desc: \$1 value");
- $desc = "substitution /r with replacement tainted";
+ $desc = "substitution /r with whole replacement tainted";
$s = 'abcd';
- $res = $s =~ s/(.+)/xyz$TAINT/r;
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
$one = $1;
isnt_tainted($s, "$desc: s not tainted");
is_tainted($res, "$desc: res tainted");
is($res, 1, "$desc: res value");
is($one, 'a', "$desc: \$1 value");
- $desc = "use re 'taint': match with pattern tainted via locale";
+ SKIP: {
+ skip 'Locales not available', 10 unless locales_enabled('LC_CTYPE');
- $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 with pattern tainted via locale";
- $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");
+ $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');
+
+ $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");
+
+ $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 partial replacement tainted";
$s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; }
+ $res = $s =~ s/(.+)/xyz$TAINT/;
+ $one = $1;
is_tainted($s, "$desc: s tainted");
isnt_tainted($res, "$desc: res not tainted");
- is_tainted($one, "$desc: \$1 tainted");
+ isnt_tainted($one, "$desc: \$1 not 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";
+ $desc = "use re 'taint': substitution /g with partial replacement tainted";
$s = 'abcd';
- { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; }
+ $res = $s =~ s/(.)/x$TAINT/g;
+ $one = $1;
is_tainted($s, "$desc: s tainted");
- is_tainted($res, "$desc: res tainted");
- is_tainted($one, "$desc: \$1 tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not 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";
+ $desc = "use re 'taint': substitution /ge with partial replacement tainted";
+
+ $s = 'abc';
+ {
+ my $i = 0;
+ my $j;
+ $res = $s =~ s{(.)}{
+ $j = $i; # make sure code not tainted
+ $one = $1;
+ isnt_tainted($j, "$desc: code not tainted within /e");
+ $i++;
+ if ($i == 1) {
+ isnt_tainted($s, "$desc: s not tainted loop 1");
+ }
+ else {
+ is_tainted($s, "$desc: s tainted loop $i");
+ }
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ $i.$TAINT;
+ }ge;
+ $one = $1;
+ }
+ is_tainted($s, "$desc: s 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($one, 'c', "$desc: \$1 value");
+
+ $desc = "use re 'taint': substitution /r with partial replacement tainted";
$s = 'abcd';
- { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
+ $res = $s =~ s/(.+)/xyz$TAINT/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");
+ isnt_tainted($one, "$desc: \$1 not 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 whole replacement tainted";
$s = 'abcd';
- $res = $s =~ s/(.+)/xyz$TAINT/;
+ $res = $s =~ s/(.+)/$TAINTXYZ/;
$one = $1;
is_tainted($s, "$desc: s tainted");
isnt_tainted($res, "$desc: res not tainted");
is($res, 1, "$desc: res value");
is($one, 'abcd', "$desc: \$1 value");
- $desc = "use re 'taint': substitution /g with replacement tainted";
+ $desc = "use re 'taint': substitution /g with whole replacement tainted";
$s = 'abcd';
- $res = $s =~ s/(.)/x$TAINT/g;
+ $res = $s =~ s/(.)/$TAINTXYZ/g;
$one = $1;
is_tainted($s, "$desc: s tainted");
isnt_tainted($res, "$desc: res not tainted");
isnt_tainted($one, "$desc: \$1 not tainted");
- is($s, 'xxxx', "$desc: s value");
+ is($s, 'xyz' x 4, "$desc: s value");
is($res, 4, "$desc: res value");
is($one, 'd', "$desc: \$1 value");
- $desc = "use re 'taint': substitution /ge with replacement tainted";
+ $desc = "use re 'taint': substitution /ge with whole replacement tainted";
$s = 'abc';
{
is_tainted($s, "$desc: s tainted loop $i");
}
isnt_tainted($one, "$desc: \$1 not tainted");
- $i.$TAINT;
+ $TAINTXYZ;
}ge;
$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($s, 'xyz' x 3, "$desc: s value");
is($res, 3, "$desc: res value");
is($one, 'c', "$desc: \$1 value");
- $desc = "use re 'taint': substitution /r with replacement tainted";
+ $desc = "use re 'taint': substitution /r with whole replacement tainted";
$s = 'abcd';
- $res = $s =~ s/(.+)/xyz$TAINT/r;
+ $res = $s =~ s/(.+)/$TAINTXYZ/r;
$one = $1;
isnt_tainted($s, "$desc: s not tainted");
is_tainted($res, "$desc: res tainted");
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/;
# Reading from a file should be tainted
{
ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!");
-
+ binmode $fh;
my $block;
sysread($fh, $block, 100);
my $line = <$fh>;
{
my $foo = "imaginary library" . $TAINT;
violates_taint(sub { require $foo }, 'require');
+ violates_taint(sub { do $foo }, 'do');
my $filename = tempfile(); # NB: $filename isn't tainted!
$foo = $filename . $TAINT;
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
+ # bug id 20001004.006 (#4380)
open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ;
local $/;
}
{
- # bug id 20001004.007
+ # bug id 20001004.007 (#4381)
open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ;
my $a = <$fh>;
}
{
- # bug id 20010519.003
+ # bug id 20010519.003 (#7015)
+ our $has_fcntl;
BEGIN {
- use vars qw($has_fcntl);
eval { require Fcntl; import Fcntl; };
unless ($@) {
$has_fcntl = 1;
}
SKIP: {
- skip "no Fcntl", 18 unless $has_fcntl;
+ skip "no Fcntl", 36 unless $has_fcntl;
my $foo = tempfile();
my $evil = $foo . $TAINT;
}
{
- # bug 20010526.004
+ # bug 20010526.004 (#7041)
use warnings;
{
- # Bug ID 20010730.010
+ # Bug ID 20010730.010 (#7387)
my $i = 0;
'Assigning to ${^TAINT} fails');
{
- # bug 20011111.105
+ # bug 20011111.105 (#7897)
my $re1 = qr/x$TAINT/;
is_tainted($re1);
SKIP: {
skip "system {} has different semantics on Win32", 1 if $Is_MSWin32;
- # bug 20010221.005
+ # bug 20010221.005 (#5882)
local $ENV{PATH} .= $TAINT;
eval { system { "echo" } "/arg0", "arg1" };
like($@, qr/^Insecure \$ENV/);
todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22
if $Is_VMS;
- # bug 20020208.005 plus some single arg exec/system extras
+ # bug 20020208.005 (#8465) plus some single arg exec/system extras
violates_taint(sub { exec $TAINT, $TAINT }, 'exec');
violates_taint(sub { exec $TAINT $TAINT }, 'exec');
violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec');
}
{
- # [ID 20020704.001] taint propagation failure
+ # [ID 20020704.001 (#10026)] taint propagation failure
use re 'taint';
$TAINT =~ /(.*)/;
is_tainted(my $foo = $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
}
{
- # 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 "IsA" in regex/,
"user-defined property: tainted case");
+
+}
+
+{
+ SKIP: {
+ skip "Environment tainting tests skipped", 1
+ if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos;
+
+ local $ENV{XX} = '\p{IsB}'; # Making it an environment variable taints it
+
+ fresh_perl_like(<<'EOF',
+ BEGIN { $re = qr/$ENV{XX}/; }
+
+ sub IsB { "42" };
+ "B" =~ $re
+EOF
+ qr/Insecure user-defined property \\p\{main::IsB\}/,
+ { switches => [ "-T" ] },
+ "user-defined property; defn not known until runtime, tainted case");
+ }
}
{
{
# Taintedness of values returned from given()
use feature 'switch';
+ no warnings 'experimental::smartmatch';
my @descriptions = ('when', 'given end', 'default');
# 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) {
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;
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
+}
+
+# RT #129996
+# every item in a list assignment is independent, even if the lvalue
+# has taint magic already
+{
+ my ($a, $b, $c, $d);
+ $d = "";
+ $b = $TAINT;
+ ($a, $b, $c) = ($TAINT, 0, 0);
+ is_tainted $a, "list assign tainted a";
+ isnt_tainted $b, "list assign tainted b";
+ isnt_tainted $c, "list assign tainted c";
+
+ $b = $TAINT;
+ $b = ""; # untaint;
+ ($a, $b, $c) = ($TAINT, 0, 0);
+ is_tainted $a, "list assign detainted a";
+ isnt_tainted $b, "list assign detainted b";
+ isnt_tainted $c, "list assign detainted c";
+
+ $b = $TAINT;
+ $b = ""; # untaint;
+ ($a, $b, $c) = ($TAINT);
+ is_tainted $a, "list assign empty rhs a";
+ isnt_tainted $b, "list assign empty rhs b";
+ isnt_tainted $c, "list assign empty rhs c";
+
+ $b = $TAINT;
+ $b = ""; # untaint;
+ ($a = ($TAINT. "x")), (($b, $c) = (0));
+ is_tainted $a, "list assign already tainted expression a";
+ isnt_tainted $b, "list assign already tainted expression b";
+ isnt_tainted $c, "list assign already tainted expression c";
+
+ $b = $TAINT;
+ $b = ""; # untaint;
+ (($a) = ($TAINT. "x")), ($b = $b . "x");
+ is_tainted $a, "list assign post tainted expression a";
+ isnt_tainted $b, "list assign post tainted expression b";
+}
+
+# Module::Runtime was temporarily broken between 5.27.0 and 5.27.1 because
+# ref() would fail an assertion in a tainted statement. (No ok() neces-
+# sary since it aborts when it fails.)
+() = defined $^X && ref \$^X;
+
+# taint passing through overloading
+package OvTaint {
+ sub new { bless({ t => $_[1] }, $_[0]) }
+ use overload '""' => sub { $_[0]->{t} ? "hi".$TAINT : "hello" };
+}
+my $ovclean = OvTaint->new(0);
+my $ovtaint = OvTaint->new(1);
+isnt_tainted("$ovclean", "overload preserves cleanliness");
+is_tainted("$ovtaint", "overload preserves taint");
+
+# substitutions with overloaded replacement
+{
+ my ($desc, $s, $res, $one);
+
+ $desc = "substitution with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovclean/;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovtaint/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovclean/;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovtaint/;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/"xyz".$ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/"xyz".$ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), "xyz".$ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xyzhi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), $ovclean/e;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /e with extra code and whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/(my $z++), $ovtaint/e;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi', "$desc: s value");
+ is($res, 1, "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovclean/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyzhello', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/xyz$ovtaint/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'xyzhi', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovclean/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'hello', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /r with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.+)/$ovtaint/r;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ is_tainted($res, "$desc: res tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'abcd', "$desc: s value");
+ is($res, 'hi', "$desc: res value");
+ is($one, 'abcd', "$desc: \$1 value");
+
+ $desc = "substitution /g with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/x$ovclean/g;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /g with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/x$ovtaint/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /g with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovclean/g;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /g with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovtaint/g;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with partial replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/"x".$ovclean/ge;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with partial replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/"x".$ovtaint/ge;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'xhi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with whole replacement overloaded and clean";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovclean/ge;
+ $one = $1;
+ isnt_tainted($s, "$desc: s not tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hello' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+
+ $desc = "substitution /ge with whole replacement overloaded and tainted";
+ $s = 'abcd';
+ $res = $s =~ s/(.)/$ovtaint/ge;
+ $one = $1;
+ is_tainted($s, "$desc: s tainted");
+ isnt_tainted($res, "$desc: res not tainted");
+ isnt_tainted($one, "$desc: \$1 not tainted");
+ is($s, 'hi' x 4, "$desc: s value");
+ is($res, 4, "$desc: res value");
+ is($one, 'd', "$desc: \$1 value");
+}
+
+# RT #132385
+# It was trying to taint a boolean return from s/// (e.g. PL_sv_yes)
+# and was thus crashing with 'Modification of a read-only value'.
+
+{
+ my $s = "abcd" . $TAINT;
+ ok(!!($s =~ s/a/x/g), "RT #132385");
+}
+
+# RT #134409
+# When the last substitution added both taint and utf8, adding taint
+# magic to the result also triggered a byte-to-utf8 recalulation of the
+# existing pos() magic, which had not yet been reset, resulting in a panic
+# about pos() being off the end of the string.
+{
+ my $utf8_taint = substr($^X,0,0);
+ utf8::upgrade($utf8_taint);
+
+ my %map = (
+ 'UTF8' => "$utf8_taint",
+ 'PLAIN' => '',
+ );
+
+
+ my $v = "PLAIN UTF8";
+ my $c = eval { $v =~ s/(\w+)/$map{$1}/g; };
+ is($c, 2, "RT #134409")
+ or diag("\$@ = [$@]");
+}
+
+{
+ # check that each param is independent taint-wise.
+ use feature 'signatures';
+ use experimental 'signatures';
+
+ sub taint_sig1($a, $b, $c) {
+ isnt_tainted($a, 'taint_sig1: $a');
+ is_tainted ($b, 'taint_sig1: $b');
+ isnt_tainted($c, 'taint_sig1: $c');
+ }
+ taint_sig1(1, $TAINT, 3);
+
+ sub taint_sig2($a, $b = $TAINT, $c = 3) {
+ isnt_tainted($a, 'taint_sig2: $a');
+ is_tainted ($b, 'taint_sig2: $b');
+ isnt_tainted($c, 'taint_sig2: $c');
+ }
+ taint_sig2(1);
+
+ sub taint_sig3($a, $b = 2, $c = $TAINT) {
+ is_tainted ($a, 'taint_sig3: $a');
+ isnt_tainted($b, 'taint_sig3: $b');
+ is_tainted ($c, 'taint_sig3: $c');
+ }
+ taint_sig3($TAINT);
+}
+
+
# 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