Prevent call_sv() in vmg_svt_free() to clobber the last popped context slot

This caused havoc when dieing in eval at compile time because call_sv() was overwriting this slot while there was still some live pointers to it up in the call stack.

diff --git a/Magic.xs b/Magic.xs
index 858c80fcb3c831bebe0d1f0c70b9241f7b45a771..c2d8f6542f5c4af09941fd04f4aea404502d5728 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -812,6 +812,9 @@ STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
 
 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  const MGWIZ *w;
+#if VMG_HAS_PERL(5, 10, 0)
+ PERL_CONTEXT saved_cx;
+#endif
  unsigned int had_err, has_err, flags = G_SCALAR | G_EVAL;
  int ret = 0;
 
@@ -849,8 +852,21 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  if (had_err)
   flags |= G_KEEPERR;
 
+#if VMG_HAS_PERL(5, 10, 0)
+ /* This context should not be used anymore, but since we croak in places the
+  * core doesn't even dare to, some pointers to it may remain in the upper call
+  * stack. Make sure call_sv() doesn't clobber it. */
+ if (cxstack_ix >= cxstack_max)
+  Perl_cxinc(aTHX);
+ saved_cx = cxstack[cxstack_ix + 1];
+#endif
+
  call_sv(w->cb_free, flags);
 
+#if VMG_HAS_PERL(5, 10, 0)
+ cxstack[cxstack_ix + 1] = saved_cx;
+#endif
+
  has_err = SvTRUE(ERRSV);
  if (IN_PERL_COMPILETIME && !had_err && has_err)
   ++PL_error_count;
@@ -863,7 +879,10 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  if (has_err) {
   /* Get the eval context that was pushed by call_sv, and fake an entry for the
    * namesv, as die_where will need it to be non NULL later */
-  PERL_CONTEXT *cx = cxstack + cxstack_ix + 1;
+  PERL_CONTEXT *cx;
+  if (cxstack_ix >= cxstack_max)
+   Perl_cxinc(aTHX);
+  cx = cxstack + cxstack_ix + 1;
   if (!cx->blk_eval.old_namesv)
    cx->blk_eval.old_namesv
                  = sv_2mortal(newSVpvn_share("Variable/Magic/DUMMY.pm", 23, 0));

diff --git a/t/17-ctl.t b/t/17-ctl.t
index 7e2e7d8440c4bc3f0e5bbb1313c19d7b04b1ccf5..a7557aeb6567ecc6e6497071bf657bf199651c33 100644 (file)
--- a/t/17-ctl.t
+++ b/t/17-ctl.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 8 + 1;
+use Test::More tests => 10 + 1;
 
 use Variable::Magic qw/wizard cast/;
 
@@ -79,3 +79,12 @@ use lib 't/lib';
 eval "use Variable::Magic::TestScopeEnd";
 
 like $@, qr/turnip/, 'die in BEGIN in require triggers hints hash destructor';
+
+eval q{BEGIN {
+ Variable::Magic::TestScopeEnd::hook {
+  pass 'in hints hash destructor 2';
+ };
+ die "tomato";
+}};
+
+like $@, qr/tomato/, 'die in BEGIN in eval triggers hints hash destructor';