+
+SKIP: {
+ skip "no IPC::SysV", 2 unless $ipcsysv;
+
+ # test shmread
+ SKIP: {
+ skip "shm*() not available", 1 unless $Config{d_shm};
+
+ no strict 'subs';
+ my $sent = "foobar";
+ my $rcvd;
+ my $size = 2000;
+ my $id = shmget(IPC_PRIVATE, $size, S_IRWXU);
+
+ if (defined $id) {
+ if (shmwrite($id, $sent, 0, 60)) {
+ if (shmread($id, $rcvd, 0, 60)) {
+ substr($rcvd, index($rcvd, "\0")) = '';
+ } else {
+ warn "# shmread failed: $!\n";
+ }
+ } else {
+ warn "# shmwrite failed: $!\n";
+ }
+ shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n";
+ } else {
+ warn "# shmget failed: $!\n";
+ }
+
+ skip "SysV shared memory operation failed", 1 unless
+ $rcvd eq $sent;
+
+ test tainted $rcvd;
+ }
+
+
+ # test msgrcv
+ SKIP: {
+ skip "msg*() not available", 1 unless $Config{d_msg};
+
+ no strict 'subs';
+ my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
+
+ my $sent = "message";
+ my $type_sent = 1234;
+ my $rcvd;
+ my $type_rcvd;
+
+ if (defined $id) {
+ if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) {
+ if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) {
+ ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd);
+ } else {
+ warn "# msgrcv failed: $!\n";
+ }
+ } else {
+ warn "# msgsnd failed: $!\n";
+ }
+ msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n";
+ } else {
+ warn "# msgget failed\n";
+ }
+
+ SKIP: {
+ skip "SysV message queue operation failed", 1
+ unless $rcvd eq $sent && $type_sent == $type_rcvd;
+
+ test tainted $rcvd;
+ }
+ }
+}
+
+{
+ # bug id 20001004.006
+
+ open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
+ local $/;
+ my $a = <IN>;
+ my $b = <IN>;
+
+ ok tainted($a) && tainted($b) && !defined($b);
+
+ close IN;
+}
+
+{
+ # bug id 20001004.007
+
+ open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
+ my $a = <IN>;
+
+ my $c = { a => 42,
+ b => $a };
+
+ ok !tainted($c->{a}) && tainted($c->{b});
+
+
+ my $d = { a => $a,
+ b => 42 };
+ ok tainted($d->{a}) && !tainted($d->{b});
+
+
+ my $e = { a => 42,
+ b => { c => $a, d => 42 } };
+ ok !tainted($e->{a}) &&
+ !tainted($e->{b}) &&
+ tainted($e->{b}->{c}) &&
+ !tainted($e->{b}->{d});
+
+ close IN;
+}
+
+{
+ # bug id 20010519.003
+
+ BEGIN {
+ use vars qw($has_fcntl);
+ eval { require Fcntl; import Fcntl; };
+ unless ($@) {
+ $has_fcntl = 1;
+ }
+ }
+
+ SKIP: {
+ skip "no Fcntl", 18 unless $has_fcntl;
+
+ my $evil = "foo" . $TAINT;
+
+ eval { sysopen(my $ro, $evil, &O_RDONLY) };
+ test $@ !~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $wo, $evil, &O_WRONLY) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $rw, $evil, &O_RDWR) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ap, $evil, &O_APPEND) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $cr, $evil, &O_CREAT) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $tr, $evil, &O_TRUNC) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ro, "foo", &O_RDONLY | $TAINT0) };
+ test $@ !~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $wo, "foo", &O_WRONLY | $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $rw, "foo", &O_RDWR | $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ap, "foo", &O_APPEND | $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $cr, "foo", &O_CREAT | $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $tr, "foo", &O_TRUNC | $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ro, "foo", &O_RDONLY, $TAINT0) };
+ test $@ !~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $wo, "foo", &O_WRONLY, $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $rw, "foo", &O_RDWR, $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $ap, "foo", &O_APPEND, $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $cr, "foo", &O_CREAT, $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ eval { sysopen(my $tr, "foo", &O_TRUNC, $TAINT0) };
+ test $@ =~ /^Insecure dependency/, $@;
+
+ unlink("foo"); # not unlink($evil), because that would fail...
+ }
+}
+
+{
+ # bug 20010526.004
+
+ use warnings;
+
+ my $saw_warning = 0;
+ local $SIG{__WARN__} = sub { $saw_warning = 1 };
+
+ sub fmi {
+ my $divnum = shift()/1;
+ sprintf("%1.1f\n", $divnum);
+ }
+
+ fmi(21 . $TAINT);
+ fmi(37);
+ fmi(248);
+
+ test !$saw_warning;
+}
+
+
+{
+ # Bug ID 20010730.010
+
+ my $i = 0;
+
+ sub Tie::TIESCALAR {
+ my $class = shift;
+ my $arg = shift;
+
+ bless \$arg => $class;
+ }
+
+ sub Tie::FETCH {
+ $i ++;
+ ${$_ [0]}
+ }
+
+
+ package main;
+
+ my $bar = "The Big Bright Green Pleasure Machine";
+ taint_these $bar;
+ tie my ($foo), Tie => $bar;
+
+ my $baz = $foo;
+
+ ok $i == 1;
+}
+
+{
+ # Check that all environment variables are tainted.
+ my @untainted;
+ while (my ($k, $v) = each %ENV) {
+ if (!tainted($v) &&
+ # These we have explicitly untainted or set earlier.
+ $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) {
+ push @untainted, "# '$k' = '$v'\n";
+ }
+ }
+ test @untainted == 0, "untainted:\n @untainted";
+}
+
+
+ok( ${^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' );
+
+{
+ # bug 20011111.105
+
+ my $re1 = qr/x$TAINT/;
+ test tainted $re1;
+
+ my $re2 = qr/^$re1\z/;
+ test tainted $re2;
+
+ my $re3 = "$re2";
+ test tainted $re3;
+}
+
+SKIP: {
+ skip "system {} has different semantics on Win32", 1 if $Is_MSWin32;
+
+ # bug 20010221.005
+ local $ENV{PATH} .= $TAINT;
+ eval { system { "echo" } "/arg0", "arg1" };
+ test $@ =~ /^Insecure \$ENV/;
+}
+
+TODO: {
+ todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22
+ if $Is_VMS;
+
+ # bug 20020208.005 plus some single arg exec/system extras
+ my $err = qr/^Insecure dependency/ ;
+ test !eval { exec $TAINT, $TAINT }, 'exec';
+ test $@ =~ $err, $@;
+ test !eval { exec $TAINT $TAINT }, 'exec';
+ test $@ =~ $err, $@;
+ test !eval { exec $TAINT $TAINT, $TAINT }, 'exec';
+ test $@ =~ $err, $@;
+ test !eval { exec $TAINT 'notaint' }, 'exec';
+ test $@ =~ $err, $@;
+ test !eval { exec {'notaint'} $TAINT }, 'exec';
+ test $@ =~ $err, $@;
+
+ test !eval { system $TAINT, $TAINT }, 'system';
+ test $@ =~ $err, $@;
+ test !eval { system $TAINT $TAINT }, 'system';
+ test $@ =~ $err, $@;
+ test !eval { system $TAINT $TAINT, $TAINT }, 'system';
+ test $@ =~ $err, $@;
+ test !eval { system $TAINT 'notaint' }, 'system';
+ test $@ =~ $err, $@;
+ test !eval { system {'notaint'} $TAINT }, 'system';
+ test $@ =~ $err, $@;
+
+ eval {
+ no warnings;
+ system("lskdfj does not exist","with","args");
+ };
+ test !$@;
+
+ SKIP: {
+ skip "no exec() on MacOS Classic" if $Is_MacOS;
+
+ eval {
+ no warnings;
+ exec("lskdfj does not exist","with","args");
+ };
+ test !$@;
+ }
+
+ # If you add tests here update also the above skip block for VMS.
+}
+
+{
+ # [ID 20020704.001] taint propagation failure
+ use re 'taint';
+ $TAINT =~ /(.*)/;
+ test tainted(my $foo = $1);
+}
+
+{
+ # [perl #24291] this used to dump core
+ our %nonmagicalenv = ( PATH => "util" );
+ local *ENV = \%nonmagicalenv;
+ eval { system("lskdfj"); };
+ test $@ =~ /^%ENV is aliased to another variable while running with -T switch/;
+ local *ENV = *nonmagicalenv;
+ eval { system("lskdfj"); };
+ test $@ =~ /^%ENV is aliased to %nonmagicalenv while running with -T switch/;
+}
+{
+ # [perl #24248]
+ $TAINT =~ /(.*)/;
+ test !tainted($1);
+ my $notaint = $1;
+ test !tainted($notaint);
+
+ my $l;
+ $notaint =~ /($notaint)/;
+ $l = $1;
+ test !tainted($1);
+ test !tainted($l);
+ $notaint =~ /($TAINT)/;
+ $l = $1;
+ test tainted($1);
+ test tainted($l);
+
+ $TAINT =~ /($notaint)/;
+ $l = $1;
+ test !tainted($1);
+ test !tainted($l);
+ $TAINT =~ /($TAINT)/;
+ $l = $1;
+ test tainted($1);
+ test tainted($l);
+
+ my $r;
+ ($r = $TAINT) =~ /($notaint)/;
+ test !tainted($1);
+ ($r = $TAINT) =~ /($TAINT)/;
+ test tainted($1);
+
+ # [perl #24674]
+ # accessing $^O shoudn't taint it as a side-effect;
+ # assigning tainted data to it is now an error
+
+ test !tainted($^O);
+ if (!$^X) { } elsif ($^O eq 'bar') { }
+ test !tainted($^O);
+ eval '$^O = $^X';
+ test $@ =~ /Insecure dependency in/;
+}
+
+EFFECTIVELY_CONSTANTS: {
+ my $tainted_number = 12 + $TAINT0;
+ test tainted( $tainted_number );
+
+ # Even though it's always 0, it's still tainted
+ my $tainted_product = $tainted_number * 0;
+ test tainted( $tainted_product );
+ test $tainted_product == 0;
+}
+
+TERNARY_CONDITIONALS: {
+ my $tainted_true = $TAINT . "blah blah blah";
+ my $tainted_false = $TAINT0;
+ test tainted( $tainted_true );
+ test tainted( $tainted_false );
+
+ my $result = $tainted_true ? "True" : "False";
+ test $result eq "True";
+ test !tainted( $result );
+
+ $result = $tainted_false ? "True" : "False";
+ test $result eq "False";
+ test !tainted( $result );
+
+ my $untainted_whatever = "The Fabulous Johnny Cash";
+ my $tainted_whatever = "Soft Cell" . $TAINT;
+
+ $result = $tainted_true ? $tainted_whatever : $untainted_whatever;
+ test $result eq "Soft Cell";
+ test tainted( $result );
+
+ $result = $tainted_false ? $tainted_whatever : $untainted_whatever;
+ test $result eq "The Fabulous Johnny Cash";
+ test !tainted( $result );
+}
+
+{
+ # rt.perl.org 5900 $1 remains tainted if...
+ # 1) The regular expression contains a scalar variable AND
+ # 2) The regular expression appears in an elsif clause
+
+ my $foo = "abcdefghi" . $TAINT;
+
+ my $valid_chars = 'a-z';
+ if ( $foo eq '' ) {
+ }
+ elsif ( $foo =~ /([$valid_chars]+)/o ) {
+ test not tainted $1;
+ }
+
+ if ( $foo eq '' ) {
+ }
+ elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) {
+ test not any_tainted @bar;
+ }
+}
+
+# at scope exit, a restored localised value should have its old
+# taint status, not the taint status of the current statement
+
+{
+ our $x99 = $^X;
+ test tainted $x99;
+
+ $x99 = '';
+ test not tainted $x99;
+
+ my $c = do { local $x99; $^X };
+ test not tainted $x99;
+}
+{
+ our $x99 = $^X;
+ test tainted $x99;
+
+ my $c = do { local $x99; '' };
+ test tainted $x99;
+}
+
+# an mg_get of a tainted value during localization shouldn't taint the
+# statement
+
+{
+ eval { local $0, eval '1' };
+ test $@ eq '';
+}
+
+# [perl #8262] //g loops infinitely on tainted data
+
+{
+ my @a;
+ local $::TODO = 1;
+ $a[0] = $^X;
+ my $i = 0;
+ while($a[0]=~ m/(.)/g ) {
+ last if $i++ > 10000;
+ }
+ cmp_ok $i, '<', 10000, "infinite m//g";
+}
+
+SKIP:
+{
+ my $got_dualvar;
+ eval 'use Scalar::Util "dualvar"; $got_dualvar++';
+ skip "No Scalar::Util::dualvar" unless $got_dualvar;
+ my $a = Scalar::Util::dualvar(3, $^X);
+ my $b = $a + 5;
+ is ($b, 8, "Arithmetic on tainted dualvars works");
+}
+
+# opening '|-' should not trigger $ENV{PATH} check
+
+{
+ SKIP: {
+ skip "fork() is not available", 3 unless $Config{'d_fork'};
+ skip "opening |- is not stable on threaded OpenBSD with taint", 3
+ if $Config{useithreads} && $Is_OpenBSD;
+
+ $ENV{'PATH'} = $TAINT;
+ local $SIG{'PIPE'} = 'IGNORE';
+ eval {
+ my $pid = open my $pipe, '|-';
+ if (!defined $pid) {
+ die "open failed: $!";
+ }
+ if (!$pid) {
+ kill 'KILL', $$; # child suicide
+ }
+ close $pipe;
+ };
+ test $@ !~ /Insecure \$ENV/, 'fork triggers %ENV check';
+ test $@ eq '', 'pipe/fork/open/close failed';
+ eval {
+ open my $pipe, "|$Invoke_Perl -e 1";
+ close $pipe;
+ };
+ test $@ =~ /Insecure \$ENV/, 'popen neglects %ENV check';
+ }
+}
+
+{
+ package AUTOLOAD_TAINT;
+ sub AUTOLOAD {
+ our $AUTOLOAD;
+ return if $AUTOLOAD =~ /DESTROY/;
+ if ($AUTOLOAD =~ /untainted/) {
+ main::ok(!main::tainted($AUTOLOAD), '$AUTOLOAD can be untainted');
+ } else {
+ main::ok(main::tainted($AUTOLOAD), '$AUTOLOAD can be tainted');
+ }
+ }
+
+ package main;
+ my $o = bless [], 'AUTOLOAD_TAINT';
+ $o->$TAINT;
+ $o->untainted;
+}
+
+{
+ # 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/);
+ 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/);
+ eval { sprintf("# %s\n", $TAINT . "foo") };
+ ok(!$@, q/sprintf accepts other tainted args/);
+}