From: Dave Mitchell <davem@fdisolutions.com>
Date: Mon, 9 Aug 2004 19:48:57 +0000 (+0000)
Subject: eval_sv() failing a taint test could corrupt the stack
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dedbcade96321798da47de9721e77227a1c11eb5;p=p5sagit%2Fp5-mst-13.2.git

eval_sv() failing a taint test could corrupt the stack

p4raw-id: //depot/perl@23209
---

diff --git a/ext/XS/APItest/t/call.t b/ext/XS/APItest/t/call.t
index b33e12a..be66a73 100644
--- a/ext/XS/APItest/t/call.t
+++ b/ext/XS/APItest/t/call.t
@@ -19,9 +19,14 @@ BEGIN {
 use warnings;
 use strict;
 
-use Test::More tests => 239;
+# Test::MJore doesn't have fresh_perl_is() yet
+# use Test::More tests => 240;
 
-BEGIN { use_ok('XS::APItest') };
+BEGIN {
+    require './test.pl';
+    plan(240);
+    use_ok('XS::APItest')
+};
 
 #########################
 
@@ -132,9 +137,12 @@ for my $test (
     ok(eq_array( [ eval { call_pv('d', $flags, @$args) }, $@ ],
 	[ "its_dead_jim\n" ]), "$description eval { call_pv('d') }");
 
+    #use Data::Dumper; print Dumper([ eval { eval_sv('d', $flags), $@ }, $@ ]);
+#    print Dumper([ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1),
+#		"its_dead_jim\n", undef ]);
     ok(eq_array( [ eval { eval_sv('d', $flags), $@ }, $@ ],
 	[ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1),
-		"its_dead_jim\n", undef ]),
+		"its_dead_jim\n", '' ]),
 	"$description eval { eval_sv('d') }");
 
     ok(eq_array( [ eval { call_method('d', $flags, $obj, @$args) }, $@ ],
@@ -148,3 +156,22 @@ is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
 is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
 is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
 is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
+
+# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
+# a new jump level but before pushing an eval context, leading to
+# stack corruption
+
+fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, 'eval_sv() taint');
+use XS::APItest;
+
+my $x = 0;
+sub f {
+    eval { my @a = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
+    $x++;
+    $a <=> $b;
+}
+
+eval { my @a = sort f 2, 1;  $x++};
+print "x=$x\n";
+EOF
+
diff --git a/perl.c b/perl.c
index 4af4e06..1040163 100644
--- a/perl.c
+++ b/perl.c
@@ -2200,6 +2200,10 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
 		(OP*)&myop, TRUE);
 #else
+    /* fail now; otherwise we could fail after the JMPENV_PUSH but
+     * before a PUSHEVAL, which corrupts the stack after a croak */
+    TAINT_PROPER("eval_sv()");
+
     JMPENV_PUSH(ret);
 #endif
     switch (ret) {