Change 30130 by [EMAIL PROTECTED] on 2007/02/05 16:25:02
Integrate:
[ 24535]
[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
[ 24642]
add pointer to email explaining why eval {goto &foo} is banned
Affected files ...
... //depot/maint-5.8/perl/pp_ctl.c#171 integrate
... //depot/maint-5.8/perl/t/op/goto_xs.t#4 integrate
Differences ...
==== //depot/maint-5.8/perl/pp_ctl.c#171 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#170~30127~ 2007-02-05 03:57:18.000000000 -0800
+++ perl/pp_ctl.c 2007-02-05 08:25:02.000000000 -0800
@@ -2185,6 +2185,7 @@
dounwind(cxix);
TOPBLOCK(cx);
SPAGAIN;
+ /* ban goto in eval: see <[EMAIL PROTECTED]> */
if (CxTYPE(cx) == CXt_EVAL) {
if (CxREALEVAL(cx))
DIE(aTHX_ "Can't goto subroutine from an eval-string");
@@ -2237,6 +2238,7 @@
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
+ OP* retop = pop_return();
if (reified) {
I32 index;
for (index=0; index<items; index++)
@@ -2261,21 +2263,20 @@
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! */
/* Put these at the bottom since the vars are set but not
used */
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
}
LEAVE;
- return pop_return();
+ return retop;
}
else {
AV* const padlist = CvPADLIST(cv);
==== //depot/maint-5.8/perl/t/op/goto_xs.t#4 (xtext) ====
Index: perl/t/op/goto_xs.t
--- perl/t/op/goto_xs.t#3~29733~ 2007-01-09 03:12:58.000000000 -0800
+++ perl/t/op/goto_xs.t 2007-02-05 08:25:02.000000000 -0800
@@ -21,7 +21,7 @@
or do { print "1..0\n# $_ 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
@@ -97,3 +97,20 @@
$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";
+}
+
End of Patch.
