diff options
| -rw-r--r-- | pp_ctl.c | 11 | ||||
| -rw-r--r-- | t/op/goto.t | 17 |
2 files changed, 26 insertions, 2 deletions
@@ -2877,6 +2877,7 @@ PP(pp_goto) PERL_CONTEXT *cx; CV *cv = MUTABLE_CV(SvRV(sv)); AV *arg = GvAV(PL_defgv); + CV *old_cv = NULL; while (!CvROOT(cv) && !CvXSUB(cv)) { const GV * const gv = CvGV(cv); @@ -2980,7 +2981,13 @@ PP(pp_goto) if (CxTYPE(cx) == CXt_SUB) { CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth; - SvREFCNT_dec_NN(cx->blk_sub.cv); + /*on XS calls defer freeing the old CV as it could + * prematurely set PL_op to NULL, which could cause + * e..g XS subs using GIMME_V to SEGV */ + if (CvISXSUB(cv)) + old_cv = cx->blk_sub.cv; + else + SvREFCNT_dec_NN(cx->blk_sub.cv); } /* Now do some callish stuff. */ @@ -2993,6 +3000,8 @@ PP(pp_goto) ENTER; SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ + if (old_cv) + SAVEFREESV(old_cv); /* ditto, deferred freeing of old CV */ /* put GvAV(defgv) back onto stack */ if (items) { diff --git a/t/op/goto.t b/t/op/goto.t index 31bf2b2f31..d951aefcdf 100644 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -11,7 +11,7 @@ BEGIN { use warnings; use strict; -plan tests => 131; +plan tests => 133; our $TODO; my $deprecated = 0; @@ -935,3 +935,18 @@ SKIP: @a = g_19188(); is ($XS::APItest::GIMME_V, 3, 'xs_goto indirect list (#19188)'); } + +# GH #19936 segfault on goto &xs_sub when calling sub is replaced +SKIP: +{ + skip "No XS::APItest in miniperl", 2 if is_miniperl(); + + # utf8::is_utf8() is just an example of an XS sub + sub foo_19936 { *foo_19936 = {}; goto &utf8::is_utf8 } + ok(foo_19936("\x{100}"), "GH #19936 utf8 XS call"); + + # the gimme XS function accesses PL_op, which was null before the fix + sub bar_19936 { *bar_19936 = {}; goto &XS::APItest::gimme } + my @a = bar_19936(); + is($XS::APItest::GIMME_V, 3, "GH #19936 gimme XS call"); +} |