X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Ftaint.t;h=7c83019e7cfc5f0e0f07a08fa8c182b41a63dd49;hb=0bc0ad857ef0ded50c72fba42503c958a1579a5a;hp=890f8f23fa7bdcd6d973bd99776c6d368b747b8b;hpb=6310abf6af0e3f228aaa2bbc3804ec9c5bddad75;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/taint.t b/t/op/taint.t index 890f8f2..7c83019 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -9,32 +9,57 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use strict; use Config; +my $test = 177; +sub ok { + my($ok, $name) = @_; + + # You have to do it this way or VMS will get confused. + print $ok ? "ok $test - $name\n" : "not ok $test - $name\n"; + + printf "# Failed test at line %d\n", (caller)[2] unless $ok; + + $test++; + return $ok; +} + + +$| = 1; + # We do not want the whole taint.t to fail # just because Errno possibly failing. eval { require Errno; import Errno }; +use vars qw($ipcsysv); # did we manage to load IPC::SysV? + BEGIN { if ($^O eq 'VMS' && !defined($Config{d_setenv})) { $ENV{PATH} = $ENV{PATH}; $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; } - if ($Config{d_shm} || $Config{d_msg}) { - require IPC::SysV; - IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ + && ($Config{d_shm} || $Config{d_msg})) { + eval { require IPC::SysV }; + unless ($@) { + $ipcsysv++; + IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + } } } my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; +my $Is_NetWare = $^O eq 'NetWare'; my $Is_Dos = $^O eq 'dos'; +my $Is_Cygwin = $^O eq 'cygwin'; my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : - $Is_MSWin32 ? '.\perl' : './perl'; + ($Is_MSWin32 ? '.\perl' : + ($Is_NetWare ? 'perl' : './perl')); my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; if ($Is_VMS) { @@ -91,14 +116,14 @@ sub test ($$;$) { } # We need an external program to call. -my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$"); +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; my $echo = "$Invoke_Perl $ECHO"; -print "1..151\n"; +print "1..183\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -110,9 +135,15 @@ print "1..151\n"; delete @ENV{@MoreEnv}; $ENV{TERM} = 'dumb'; + if ($Is_Cygwin && ! -f 'cygwin1.dll') { + system("/usr/bin/cp /usr/bin/cygwin1.dll .") && + die "$0: failed to cp cygwin1.dll: $!\n"; + END { unlink "cygwin1.dll" } # yes, done for all platforms... + } + test 1, eval { `$echo 1` } eq "1\n"; - if ($Is_MSWin32 || $Is_VMS || $Is_Dos) { + if ($Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos) { print "# Environment tainting tests skipped\n"; for (2..5) { print "ok $_\n" } } @@ -136,12 +167,12 @@ print "1..151\n"; } my $tmp; - if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) { + if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) { print "# all directories are writeable\n"; } else { $tmp = (grep { defined and -d and (stat _)[2] & 2 } - qw(/tmp /var/tmp /usr/tmp /sys$scratch), + qw(sys$scratch /tmp /var/tmp /usr/tmp), @ENV{qw(TMP TEMP)})[0] or print "# can't find world-writeable directory to test PATH\n"; } @@ -546,7 +577,7 @@ else { # Test for system/library calls returning string data of dubious origin. { # No reliable %Config check for getpw* - if (eval { setpwent(); getpwent(); 1 }) { + if (eval { setpwent(); getpwent() }) { setpwent(); my @getpwent = getpwent(); die "getpwent: $!\n" unless (@getpwent); @@ -612,13 +643,17 @@ else { # test shmread { - if ($Config{d_shm}) { + unless ($ipcsysv) { + print "ok 150 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) { no strict 'subs'; my $sent = "foobar"; my $rcvd; my $size = 2000; - my $id = shmget(IPC_PRIVATE, $size, S_IRWXU) || - warn "# shmget failed: $!\n"; + my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); + if (defined $id) { if (shmwrite($id, $sent, 0, 60)) { if (shmread($id, $rcvd, 0, 60)) { @@ -629,7 +664,7 @@ else { } else { warn "# shmwrite failed: $!\n"; } - shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n"; + shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; } else { warn "# shmget failed: $!\n"; } @@ -646,7 +681,11 @@ else { # test msgrcv { - if ($Config{d_msg}) { + unless ($ipcsysv) { + print "ok 151 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) { no strict 'subs'; my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); @@ -665,7 +704,7 @@ else { } else { warn "# msgsnd failed\n"; } - msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n"; + msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; } else { warn "# msgget failed\n"; } @@ -680,3 +719,213 @@ else { } } +{ + # bug id 20001004.006 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + local $/; + my $a = ; + my $b = ; + print "not " unless tainted($a) && tainted($b) && !defined($b); + print "ok 152\n"; + close IN; +} + +{ + # bug id 20001004.007 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + my $a = ; + + my $c = { a => 42, + b => $a }; + print "not " unless !tainted($c->{a}) && tainted($c->{b}); + print "ok 153\n"; + + my $d = { a => $a, + b => 42 }; + print "not " unless tainted($d->{a}) && !tainted($d->{b}); + print "ok 154\n"; + + my $e = { a => 42, + b => { c => $a, d => 42 } }; + print "not " unless !tainted($e->{a}) && + !tainted($e->{b}) && + tainted($e->{b}->{c}) && + !tainted($e->{b}->{d}); + print "ok 155\n"; + + close IN; +} + +{ + # bug id 20010519.003 + + BEGIN { + use vars qw($has_fcntl); + eval { require Fcntl; import Fcntl; }; + unless ($@) { + $has_fcntl = 1; + } + } + + unless ($has_fcntl) { + for (156..173) { + print "ok $_ # Skip: no Fcntl (no dynaloading?)\n"; + } + } else { + my $evil = "foo" . $TAINT; + + eval { sysopen(my $ro, $evil, &O_RDONLY) }; + test 156, $@ !~ /^Insecure dependency/, $@; + + eval { sysopen(my $wo, $evil, &O_WRONLY) }; + test 157, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $rw, $evil, &O_RDWR) }; + test 158, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $ap, $evil, &O_APPEND) }; + test 159, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $cr, $evil, &O_CREAT) }; + test 160, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $tr, $evil, &O_TRUNC) }; + test 161, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $ro, "foo", &O_RDONLY | $evil) }; + test 162, $@ !~ /^Insecure dependency/, $@; + + eval { sysopen(my $wo, "foo", &O_WRONLY | $evil) }; + test 163, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $rw, "foo", &O_RDWR | $evil) }; + test 164, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $ap, "foo", &O_APPEND | $evil) }; + test 165, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $cr, "foo", &O_CREAT | $evil) }; + test 166, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $tr, "foo", &O_TRUNC | $evil) }; + test 167, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $ro, "foo", &O_RDONLY, $evil) }; + test 168, $@ !~ /^Insecure dependency/, $@; + + eval { sysopen(my $wo, "foo", &O_WRONLY, $evil) }; + test 169, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $rw, "foo", &O_RDWR, $evil) }; + test 170, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $ap, "foo", &O_APPEND, $evil) }; + test 171, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $cr, "foo", &O_CREAT, $evil) }; + test 172, $@ =~ /^Insecure dependency/, $@; + + eval { sysopen(my $tr, "foo", &O_TRUNC, $evil) }; + test 173, $@ =~ /^Insecure dependency/, $@; + + unlink("foo"); # not unlink($evil), because that would fail... + } +} + +{ + # bug 20010526.004 + + use warnings; + + $SIG{__WARN__} = sub { print "not " }; + + sub fmi { + my $divnum = shift()/1; + sprintf("%1.1f\n", $divnum); + } + + fmi(21 . $TAINT); + fmi(37); + fmi(248); + + print "ok 174\n"; +} + + +{ + # 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; + + print $i == 1 ? "ok 175\n" : "not ok 175\n" + +} + +{ + # Check that all environment variables are tainted. + my @untainted; + while (my ($k, $v) = each %ENV) { + if (!tainted($v) && + # These we have untainted explicitly earlier. + $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|TEMP|TERM|TMP)$/) { + push @untainted, "# '$k' = '$v'\n"; + } + } + print @untainted == 0 ? "ok 176\n" : "not ok 176\n"; + print "# untainted:\n", @untainted if @untainted; +} + + +ok( ${^TAINT}, '$^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 180, tainted $re1; + + my $re2 = qr/^$re1\z/; + test 181, tainted $re2; + + my $re3 = "$re2"; + test 182, tainted $re3; +} + +if ($Is_MSWin32) { + print "ok 183 # Skipped: system {} has different semantics\n"; +} +else +{ + # bug 20010221.005 + local $ENV{PATH} .= $TAINT; + eval { system { "echo" } "/arg0", "arg1" }; + test 183, $@ =~ /^Insecure \$ENV/; +}