diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-02-25 13:12:02 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1997-02-25 13:12:02 +1200 |
commit | 1e422769b80038b1bfc4f5af33438b87cc1c7a22 (patch) | |
tree | 0f5d892c1c73cebd66d4336f658f001935d92898 /t | |
parent | 2f9daededa74ef1264bd2c46743008f84bff0cfc (diff) | |
download | perl-1e422769b80038b1bfc4f5af33438b87cc1c7a22.tar.gz |
[inseparable changes from match from perl-5.003_90 to perl-5.003_91]
BUILD PROCESS
Subject: Sanity check linking with $libs
Date: Tue, 25 Feb 1997 14:13:45 -0500 (EST)
From: Andy Dougherty <doughera@fractal.phys.lafayette.edu>
Files: Configure
Msg-ID: <Pine.SOL.3.95q.970225221634.2486A-100000@fractal.lafayette.edu>
(applied based on p5p patch as commit 5c37e92e59bb92e49d5a21017cd6dc066a28ddea)
Subject: Flush stdout when printing $randbits guess
From: Chip Salzenberg <chip@perl.com>
Files: Configure
Subject: Configure changes for Irix nm
From: Helmut Jarausch <helmutjarausch@unknown>
Files: Configure
CORE LANGUAGE CHANGES
Subject: Fix perl_call_*() when !G_EVAL
Date: Tue, 25 Feb 1997 02:25:56 -0500
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: MANIFEST gv.c interp.sym perl.c perl.h pp_ctl.c pp_sys.c t/op/runlevel.t
Msg-ID: <199702250725.CAA09192@aatma.engin.umich.edu>, <199702251925.OAA15498@aatma.engin.umich.edu>, <199702252200.RAA16853@aatma.engin.umich.edu>
(applied based on p5p patch as commits 40f788c454d994616342c409de5b5d181ad9b8af, and 907a881cde89c56bc61d3f314c0efb8754ca472a, 20efc0829f6564c44574762adb07e8865bc14026)
Subject: Fix taint tests for writeable dirs in $ENV{PATH}
From: Chip Salzenberg <chip@perl.com>
Files: mg.c mg.h pod/perlsec.pod taint.c
Subject: Forbid tainted parameters for truncate()
From: Chip Salzenberg <chip@perl.com>
Files: pp_sys.c
Subject: Don't taint magic hash keys unnecessarily
Date: Fri, 28 Feb 1997 02:11:26 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: hv.c
private-msgid: <01IFXL9TY74Y00661G@hmivax.humgen.upenn.edu>
CORE PORTABILITY
Subject: VMS patches post _90
Date: Fri, 28 Feb 1997 15:26:33 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: doio.c mg.c perl.h pp_hot.c t/op/rand.t t/op/taint.t taint.c vms/descrip.mms vms/vms.c
private-msgid: <01IFYDE5ZT7O005A53@hmivax.humgen.upenn.edu>
Subject: Fix taint check in system() and exec() under VMS and OS/2
From: Chip Salzenberg <chip@perl.com>
Files: pp_sys.c
Subject: If _XOPEN_VERSION >= 4, socket length parameters are size_t
From: Michael H. Moran <mhm@austin.ibm.com>
Files: perl.h pp_sys.c
Subject: Make dooneliner() compile again
From: Chip Salzenberg <chip@perl.com>
Files: pp_sys.c
DOCUMENTATION
Subject: Move ENVIRONMENT from perl.pod to perlrun.pod
From: Chip Salzenberg <chip@perl.com>
Files: pod/perl.pod pod/perlrun.pod
Subject: Describe PERL_DEBUG_MSTATS in perlrun.pod
From: Nat <gnat@frii.com>
Files: pod/perlrun.pod
Subject: Fix references to perlbug
From: Chip Salzenberg <chip@perl.com>
Files: pod/perl.pod pod/perldelta.pod pod/perllocale.pod pod/perltoc.pod
OTHER CORE CHANGES
Subject: Short-circuit duplicate study() calls
From: Chip Salzenberg <chip@perl.com>
Files: pp.c
Subject: Call sv_set[iu]v() with [IU]V parameter, not [IU]32
From: Chip Salzenberg <chip@perl.com>
Files: perl.c pp.c pp_sys.c toke.c util.c
Subject: Clean up and document API for hashes
Date: Tue, 25 Feb 1997 13:24:02 -0500
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: hv.c hv.h pod/perldelta.pod pod/perlguts.pod
Msg-ID: <199702251824.NAA14859@aatma.engin.umich.edu>
(applied based on p5p patch as commit a61fe43df197fcc70e6f310c06ee17d52b606c45)
Subject: pp_undef was not always freeing memory
Date: Thu, 27 Feb 1997 01:53:51 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: pp.c
Msg-ID: <199702270653.BAA13949@monk.mps.ohio-state.edu>
(applied based on p5p patch as commit 1da885048b65b5be1bd3077c6fc45f92c567e1b5)
Subject: Don't examine rx->exec_tainted if pregexec() fails
From: Chip Salzenberg <chip@perl.com>
Files: pp_hot.c
TESTS
Subject: New test op/taint.t
Date: Tue, 25 Feb 1997 11:36:53 -0800 (PST)
From: Tom Phoenix <rootbeer@teleport.com>
Files: MANIFEST t/op/taint.t
private-msgid: <Pine.GSO.3.95q.970225101328.18288M-100000@kelly.teleport.com
Subject: Patch to t/op/rand.t
Date: Tue, 25 Feb 1997 18:19:34 -0800 (PST)
From: Tom Phoenix <rootbeer@teleport.com>
Files: t/op/rand.t
private-msgid: <Pine.GSO.3.95q.970225181321.13796Q-100000@kelly.teleport.com
UTILITIES
Subject: Add --lax option to pod2man; use it in perldoc
From: Nat <gnat@frii.com>
Files: pod/pod2man.PL utils/perldoc.PL
Subject: Eliminate dead code in pod2man
From: Chip Salzenberg <chip@perl.com>
Files: pod/pod2man.PL
Diffstat (limited to 't')
-rwxr-xr-x | t/op/rand.t | 11 | ||||
-rw-r--r-- | t/op/runlevel.t | 308 | ||||
-rw-r--r-- | t/op/taint.t | 414 |
3 files changed, 730 insertions, 3 deletions
diff --git a/t/op/rand.t b/t/op/rand.t index 9e4d69284e..4eeca6b10c 100755 --- a/t/op/rand.t +++ b/t/op/rand.t @@ -74,13 +74,13 @@ sub bits ($) { # reason that the diagnostic message might get the # wrong value is that Config.pm is incorrect.) # - if ($max <= 0) { # Just in case... + if ($max <= 0 or $max >= (1 << $randbits)) { # Just in case... print "not ok 1\n"; print "# This perl was compiled with randbits=$randbits\n"; print "# which is _way_ off. Or maybe your system rand is broken,\n"; print "# or your C compiler can't multiply, or maybe Martians\n"; print "# have taken over your computer. For starters, see about\n"; - print "# trying a better value for randbits.\n"; + print "# trying a better value for randbits, probably smaller.\n"; # If that isn't the problem, we'll have # to put d_martians into Config.pm print "# Skipping remaining tests until randbits is fixed.\n"; @@ -329,7 +329,12 @@ AUTOSRAND: my($pid, $first); for (1..5) { - $pid = open PERL, "./perl -e 'print rand'|"; + if ($^O eq 'VMS') { + $pid = open PERL, qq[MCR $^X -e "print rand"|]; + } + else { + $pid = open PERL, "./perl -e 'print rand'|"; + } die "Couldn't pipe from perl: $!" unless defined $pid; if (defined $first) { if ($first ne <PERL>) { diff --git a/t/op/runlevel.t b/t/op/runlevel.t new file mode 100644 index 0000000000..ca6aac5e5b --- /dev/null +++ b/t/op/runlevel.t @@ -0,0 +1,308 @@ +#!./perl + +## +## all of these tests are from Michael Schroeder +## <Michael.Schroeder@informatik.uni-erlangen.de> +## +## The more esoteric failure modes require Michael's +## stack-of-stacks patch (so we don't test them here, +## and they are commented out before the __END__). +## +## The remaining tests pass with a simpler fix +## intended for 5.004 +## +## Gurusamy Sarathy <gsar@umich.edu> 97-02-24 +## + +chdir 't' if -d 't'; +@INC = "../lib"; +$ENV{PERL5LIB} = "../lib"; + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "runltmp000"; +1 while -f ++$tmpfile; +END { unlink $tmpfile if $tmpfile; } + +for (@prgs){ + my $switch; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + print TEST $prog, "\n"; + close TEST; + $status = $?; + $results = `cat $tmpfile`; + $results =~ s/\n+$//; + $expected =~ s/\n+$//; + if ( $results ne $expected){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +=head2 stay out of here (the real tests are after __END__) + +## +## these tests don't pass yet (need the full stack-of-stacks patch) +## GSAR 97-02-24 +## + +######## +# sort within sort +sub sortfn { + (split(/./, 'x'x10000))[0]; + my (@y) = ( 4, 6, 5); + @y = sort { $a <=> $b } @y; + print "sortfn ".join(', ', @y)."\n"; + return $_[0] <=> $_[1]; +} +@x = ( 3, 2, 1 ); +@x = sort { &sortfn($a, $b) } @x; +print "---- ".join(', ', @x)."\n"; +EXPECT +sortfn 4, 5, 6 +---- 1, 2, 3 +######## +# trapping eval within sort (doesn't work currently because +# die does a SWITCHSTACK()) +@a = (3, 2, 1); +@a = sort { eval('die("no way")') , $a <=> $b} @a; +print join(", ", @a)."\n"; +EXPECT +1, 2, 3 +######## +# this actually works fine, but results in a poor error message +@a = (1, 2, 3); +foo: +{ + @a = sort { last foo; } @a; +} +EXPECT +cannot reach destination block at - line 2. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + next; + return "ZZZ"; +} +sub STORE { +} + +package main; + +tie $bar, TEST; +{ + print "- $bar\n"; +} +print "OK\n"; +EXPECT +cannot reach destination block at - line 8. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + goto bbb; + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +exit; +bbb: +print "bbb\n"; +EXPECT +bbb +######## +# trapping eval within sort (doesn't work currently because +# die does a SWITCHSTACK()) +sub foo { + $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +package TEST; +sub TIESCALAR { + my $foo; + next; + return bless \$foo; +} +package main; +{ +tie $bar, TEST; +} +EXPECT +cannot reach destination block at - line 4. +######## +# large stack extension causes realloc, and segfault +package TEST; +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + return "fetch"; +} +sub STORE { +(split(/./, 'x'x10000))[0]; +} +package main; +tie $bar, TEST; +$bar = "x"; + +=cut + +## +## +## The real tests begin here +## +## + +__END__ +@a = (1, 2, 3); +{ + @a = sort { last ; } @a; +} +EXPECT +Can't "last" outside a block at - line 3. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + eval 'die("test")'; + print "still in fetch\n"; + return ">$@<"; +} +package main; + +tie $bar, TEST; +print "- $bar\n"; +EXPECT +still in fetch +- >test at (eval 1) line 1. +< +######## +package TEST; + +sub TIESCALAR { + my $foo; + eval('die("foo\n")'); + print "after eval\n"; + return bless \$foo; +} +sub FETCH { + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +print "OK\n"; +EXPECT +after eval +- ZZZ +OK +######## +package TEST; + +sub TIEHANDLE { + my $foo; + return bless \$foo; +} +sub PRINT { +print STDERR "PRINT CALLED\n"; +(split(/./, 'x'x10000))[0]; +eval('die("test\n")'); +} + +package main; + +open FH, ">&STDOUT"; +tie *FH, TEST; +print FH "OK\n"; +print "DONE\n"; +EXPECT +PRINT CALLED +DONE +######## +sub warnhook { + print "WARNHOOK\n"; + eval('die("foooo\n")'); +} +$SIG{'__WARN__'} = 'warnhook'; +warn("dfsds\n"); +print "END\n"; +EXPECT +WARNHOOK +END +######## +package TEST; + +use overload + "\"\"" => \&str +; + +sub str { + eval('die("test\n")'); + return "STR"; +} + +package main; + +$bar = bless {}, TEST; +print "$bar\n"; +print "OK\n"; +EXPECT +STR +OK +######## +sub foo { + $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +sub foo { + goto bar if $a == 0; + $a <=> $b; +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +exit; +bar: +print "bar reached\n"; +EXPECT +Can't "goto" outside a block at - line 2. diff --git a/t/op/taint.t b/t/op/taint.t new file mode 100644 index 0000000000..32277181f6 --- /dev/null +++ b/t/op/taint.t @@ -0,0 +1,414 @@ +#!./perl -T +# +# Taint tests by Tom Phoenix <rootbeer@teleport.com>. +# +# I don't claim to know all about tainting. If anyone sees +# tests that I've missed here, please add them. But this is +# better than having no tests at all, right? +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +use strict; +use Config; + +my $Is_VMS = $^O eq 'VMS'; +my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : './perl'; +if ($Is_VMS) { + eval <<EndOfCleanup; + END { + \$ENV{PATH} = ''; + warn "# Note: logical name 'PATH' may have been deleted\n"; + \$ENV{IFS} = "$ENV{IFS}"; + \$ENV{'DCL\$PATH'} = "$ENV{'DCL$PATH'}"; + } +EndOfCleanup +} + +# Sources of taint: +# The empty tainted value, for tainting strings +my $TAINT = substr($^X, 0, 0); +# A tainted zero, useful for tainting numbers +my $TAINT0 = 0 + $TAINT; + +# This taints each argument passed. All must be lvalues. +# Side effect: It also stringifies them. :-( +sub taint_these (@) { + for (@_) { $_ .= $TAINT } +} + +# 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; +} + +sub test ($$;$) { + my($serial, $boolean, $diag) = @_; + if ($boolean) { + print "ok $serial\n"; + } else { + print "not ok $serial\n"; + for (split m/^/m, $diag) { + print "# $_"; + } + print "\n" unless + $diag eq '' + or substr($diag, -1) eq "\n"; + } +} + +# We need an external program to call. +my $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..96\n"; + +# First, let's make sure that Perl is checking the dangerous +# environment variables. Maybe they aren't set yet, so we'll +# taint them ourselves. +{ + $ENV{'DCL$PATH'} = '' if $Is_VMS; + + $ENV{PATH} = $TAINT; + $ENV{IFS} = ''; + test 1, eval { `$echo 1` } eq ''; + test 2, $@ =~ /^Insecure \$ENV{PATH}/, $@; + + $ENV{PATH} = ''; + $ENV{IFS} = $TAINT; + test 3, eval { `$echo 1` } eq ''; + test 4, $@ =~ /^Insecure \$ENV{IFS}/, $@; + + my ($tmp) = grep { (stat)[2] & 2 } '/tmp', '/var/tmp', '/usr/tmp'; + if ($tmp) { + $ENV{PATH} = $tmp; + test 5, eval { `$echo 1` } eq ''; + test 6, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; + } + else { + print "# can't find writeable directory to test PATH tainting\n"; + for (5..6) { print "ok $_\n" } + } + + $ENV{PATH} = ''; + $ENV{IFS} = ''; + test 7, eval { `$echo 1` } eq "1\n"; + test 8, $@ eq '', $@; + + if ($Is_VMS) { + $ENV{'DCL$PATH'} = $TAINT; + test 9, eval { `$echo 1` } eq ''; + test 10, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; + $ENV{'DCL$PATH'} = ''; + } + else { + print "# This is not VMS\n"; + for (9..10) { print "ok $_\n"; } + } +} + +# Let's see that we can taint and untaint as needed. +{ + my $foo = $TAINT; + test 11, tainted $foo; + + $foo = "foo"; + test 12, not tainted $foo; + + taint_these($foo); + test 13, tainted $foo; + + my @list = 1..10; + test 14, not any_tainted @list; + taint_these @list[1,3,5,7,9]; + test 15, any_tainted @list; + test 16, all_tainted @list[1,3,5,7,9]; + test 17, not any_tainted @list[0,2,4,6,8]; + + ($foo) = $foo =~ /(.+)/; + test 18, not tainted $foo; + + $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; + test 19, not tainted $foo; + test 20, $foo eq 'bar'; + + my $pi = 4 * atan2(1,1) + $TAINT0; + test 21, tainted $pi; + + ($pi) = $pi =~ /(\d+\.\d+)/; + test 22, not tainted $pi; + test 23, sprintf("%.5f", $pi) eq '3.14159'; +} + +# How about command-line arguments? The problem is that we don't +# always get some, so we'll run another process with some. +{ + my $arg = "./arg$$"; + open PROG, "> $arg" or die "Can't create $arg: $!"; + print PROG q{ + eval { join('', @ARGV), kill 0 }; + exit 0 if $@ =~ /^Insecure dependency/; + print "# Oops: \$@ was [$@]\n"; + exit 1; + }; + close PROG; + print `$Invoke_Perl "-T" $arg and some suspect arguments`; + test 24, !$?, "Exited with status $?"; + unlink $arg; +} + +# Reading from a file should be tainted +{ + my $file = './perl' . $Config{exe_ext}; + test 25, open(FILE, $file), "Couldn't open '$file': $!"; + + my $block; + sysread(FILE, $block, 100); + my $line = <FILE>; # Should "work" + close FILE; + test 26, tainted $block; + test 27, tainted $line; +} + +# Globs should be tainted. +{ + my @globs = <*>; + test 28, all_tainted @globs; + + @globs = glob '*'; + test 29, all_tainted @globs; +} + +# Output of commands should be tainted +{ + my $foo = `$echo abc`; + test 30, tainted $foo; +} + +# Certain system variables should be tainted +{ + test 31, all_tainted $^X, $0; +} + +# Results of matching should all be untainted +{ + my $foo = "abcdefghi" . $TAINT; + test 32, tainted $foo; + + $foo =~ /def/; + test 33, not any_tainted $`, $&, $'; + + $foo =~ /(...)(...)(...)/; + test 34, not any_tainted $1, $2, $3, $+; + + my @bar = $foo =~ /(...)(...)(...)/; + test 35, not any_tainted @bar; + + test 36, tainted $foo; # $foo should still be tainted! + test 37, $foo eq "abcdefghi"; +} + +# Operations which affect files can't use tainted data. +{ + test 38, eval { chmod 0, $TAINT } eq '', 'chmod'; + test 39, $@ =~ /^Insecure dependency/, $@; + + test 40, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; + test 41, $@ =~ /^Insecure dependency/, $@; + + test 42, eval { rename '', $TAINT } eq '', 'rename'; + test 43, $@ =~ /^Insecure dependency/, $@; + + test 44, eval { unlink $TAINT } eq '', 'unlink'; + test 45, $@ =~ /^Insecure dependency/, $@; + + test 46, eval { utime $TAINT } eq '', 'utime'; + test 47, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_chown}) { + test 48, eval { chown -1, -1, $TAINT } eq '', 'chown'; + test 49, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# chown() is not available\n"; + for (48..49) { print "ok $_\n" } + } + + if ($Config{d_link}) { + test 50, eval { link $TAINT, '' } eq '', 'link'; + test 51, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# link() is not available\n"; + for (50..51) { print "ok $_\n" } + } + + if ($Config{d_symlink}) { + test 52, eval { symlink $TAINT, '' } eq '', 'symlink'; + test 53, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# symlink() is not available\n"; + for (52..53) { print "ok $_\n" } + } +} + +# Operations which affect directories can't use tainted data. +{ + test 54, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; + test 55, $@ =~ /^Insecure dependency/, $@; + + test 56, eval { rmdir $TAINT } eq '', 'rmdir'; + test 57, $@ =~ /^Insecure dependency/, $@; + + test 58, eval { chdir $TAINT } eq '', 'chdir'; + test 59, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_chroot}) { + test 60, eval { chroot $TAINT } eq '', 'chroot'; + test 61, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# chroot() is not available\n"; + for (60..61) { print "ok $_\n" } + } +} + +# Some operations using files can't use tainted data. +{ + my $foo = "imaginary library" . $TAINT; + test 62, eval { require $foo } eq '', 'require'; + test 63, $@ =~ /^Insecure dependency/, $@; + + my $filename = "./taintB$$"; # NB: $filename isn't tainted! + END { unlink $filename if defined $filename } + $foo = $filename . $TAINT; + unlink $filename; # in any case + + test 64, eval { open FOO, $foo } eq '', 'open for read'; + test 65, $@ eq '', $@; # NB: This should be allowed + test 66, $! == 2; # File not found + + test 67, eval { open FOO, "> $foo" } eq '', 'open for write'; + test 68, $@ =~ /^Insecure dependency/, $@; +} + +# Commands to the system can't use tainted data +{ + my $foo = $TAINT; + + if ($^O eq 'amigaos') { + print "# open(\"|\") is not available\n"; + for (69..72) { print "ok $_\n" } + } + else { + test 69, eval { open FOO, "| $foo" } eq '', 'popen to'; + test 70, $@ =~ /^Insecure dependency/, $@; + + test 71, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 72, $@ =~ /^Insecure dependency/, $@; + } + + test 73, eval { exec $TAINT } eq '', 'exec'; + test 74, $@ =~ /^Insecure dependency/, $@; + + test 75, eval { system $TAINT } eq '', 'system'; + test 76, $@ =~ /^Insecure dependency/, $@; + + $foo = "*"; + taint_these $foo; + + test 77, eval { `$echo 1$foo` } eq '', 'backticks'; + test 78, $@ =~ /^Insecure dependency/, $@; + + if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe + test 79, join('', eval { glob $foo } ) ne '', 'globbing'; + test 80, $@ eq '', $@; + } + else { + test 79, join('', eval { glob $foo } ) eq '', 'globbing'; + test 80, $@ =~ /^Insecure dependency/, $@; + } +} + +# Operations which affect processes can't use tainted data. +{ + test 81, eval { kill 0, $TAINT } eq '', 'kill'; + test 82, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_setpgrp}) { + test 83, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; + test 84, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# setpgrp() is not available\n"; + for (83..84) { print "ok $_\n" } + } + + if ($Config{d_setprior}) { + test 85, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; + test 86, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# setpriority() is not available\n"; + for (85..86) { print "ok $_\n" } + } +} + +# Some miscellaneous operations can't use tainted data. +{ + if ($Config{d_syscall}) { + test 87, eval { syscall $TAINT } eq '', 'syscall'; + test 88, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# syscall() is not available\n"; + for (87..88) { print "ok $_\n" } + } + + { + my $foo = "x" x 979; + taint_these $foo; + local *FOO; + my $temp = "./taintC$$"; + END { unlink $temp } + test 89, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; + + test 90, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; + test 91, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_fcntl}) { + test 92, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; + test 93, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# fcntl() is not available\n"; + for (92..93) { print "ok $_\n" } + } + + close FOO; + } +} + +# Some tests involving references +{ + my $foo = 'abc' . $TAINT; + my $fooref = \$foo; + test 94, not tainted $fooref; + test 95, tainted $$fooref; + test 96, tainted $foo; +} |