From: Dave Mitchell <davem@fdisolutions.com>
Date: Sat, 21 May 2005 22:10:19 +0000 (+0000)
Subject: [perl #35878] goto &xsub that croaks corrupts memory
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5eff7df71d0d0bb7c87e225c00e2091ae2433cb9;p=p5sagit%2Fp5-mst-13.2.git

[perl #35878] goto &xsub that croaks corrupts memory
When an XS sub is called, a CxSUB context shouldn't be pushed. Make
goto &xs_sub mimic this behaviour by first popping the old CxSUB

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

diff --git a/pp_ctl.c b/pp_ctl.c
index bb8aab7..0eac63e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2343,6 +2343,7 @@ PP(pp_goto)
 	    SAVETMPS;
 	    SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
 	    if (CvXSUB(cv)) {
+		OP* retop = cx->blk_sub.retop;
 		if (reified) {
 		    I32 index;
 		    for (index=0; index<items; index++)
@@ -2367,17 +2368,15 @@ PP(pp_goto)
 		    SV **newsp;
 		    I32 gimme;
 
+		    /* XS subs don't have a CxSUB, so pop it */
+		    POPBLOCK(cx, PL_curpm);
 		    /* Push a mark for the start of arglist */
 		    PUSHMARK(mark);
 		    PUTBACK;
 		    (void)(*CvXSUB(cv))(aTHX_ cv);
-		    /* Pop the current context like a decent sub should */
-		    POPBLOCK(cx, PL_curpm);
-		    /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
 		}
 		LEAVE;
-		assert(CxTYPE(cx) == CXt_SUB);
-		return cx->blk_sub.retop;
+		return retop;
 	    }
 	    else {
 		AV* padlist = CvPADLIST(cv);
diff --git a/t/op/goto_xs.t b/t/op/goto_xs.t
index dc8e7d7..b775e3d 100755
--- a/t/op/goto_xs.t
+++ b/t/op/goto_xs.t
@@ -20,7 +20,7 @@ BEGIN { $| = 1; }
 eval 'require Fcntl'
   or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 };
 
-print "1..10\n";
+print "1..11\n";
 
 # We don't know what symbols are defined in platform X's system headers.
 # We don't even want to guess, because some platform out there will
@@ -96,3 +96,20 @@ sub call_goto_ref { &goto_ref; }
 
 $ret = call_goto_ref($VALID);
 print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
+
+
+# [perl #35878] croak in XS after goto segfaulted
+
+use XS::APItest qw(mycroak);
+
+sub goto_croak { goto &mycroak }
+
+{
+    my $e;
+    for (1..4) {
+	eval { goto_croak("boo$_\n") };
+	$e .= $@;
+    }
+    print $e eq "boo1\nboo2\nboo3\nboo4\n" ? "ok 11\n" : "not ok 11\n";
+}
+