From: Vincent Pit <vince@profvince.com>
Date: Thu, 19 Feb 2009 00:01:28 +0000 (+0100)
Subject: Fix and test segfaults and wrong "Unknown error" exceptions when dieing in require... 
X-Git-Tag: v0.31~4
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=fbcb2462798d2fa931a5c97ebf0cec73177dce23

Fix and test segfaults and wrong "Unknown error" exceptions when dieing in require cause a free callback to fire
---

diff --git a/MANIFEST b/MANIFEST
index 23e7eef..e7cc346 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -40,4 +40,5 @@ t/91-pod.t
 t/92-pod-coverage.t
 t/95-portability-files.t
 t/99-kwalitee.t
+t/lib/Variable/Magic/TestDieRequired.pm
 t/lib/Variable/Magic/TestWatcher.pm
diff --git a/Magic.xs b/Magic.xs
index f034a28..48c8bdd 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -561,14 +561,14 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
  va_list ap;
  SV *svr;
  int ret;
- unsigned int i, args, opinfo, eval;
+ unsigned int i, args, opinfo, eval, has_err = 0;
 
  dSP;
 
  args    = flags & VMG_CB_CALL_ARGS_MASK;
  flags >>= VMG_CB_CALL_ARGS_SHIFT;
  opinfo  = flags & VMG_CB_CALL_OPINFO;
- eval    = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0;
+ eval    = flags & VMG_CB_CALL_EVAL;
 
  ENTER;
  SAVETMPS;
@@ -587,11 +587,20 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
   XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
- call_sv(cb, G_SCALAR | eval);
+ if (!eval) {
+  call_sv(cb, G_SCALAR);
+ } else {
+  unsigned int flags   = G_SCALAR | G_EVAL;
+  unsigned int had_err = SvTRUE(ERRSV);
+  if (had_err)
+   flags |= G_KEEPERR;
+  call_sv(cb, flags);
+  has_err = SvTRUE(ERRSV);
+  if (IN_PERL_COMPILETIME && !had_err && has_err)
+   ++PL_error_count;
+ }
 
  SPAGAIN;
- if (eval && IN_PERL_COMPILETIME && SvTRUE(ERRSV))
-  ++PL_error_count;
  svr = POPs;
  ret = SvOK(svr) ? SvIV(svr) : 0;
  PUTBACK;
@@ -599,6 +608,15 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
  FREETMPS;
  LEAVE;
 
+ 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;
+  if (!cx->blk_eval.old_namesv)
+   cx->blk_eval.old_namesv
+                 = sv_2mortal(newSVpvn_share("Variable/Magic/DUMMY.pm", 23, 0));
+ }
+
  return ret;
 }
 
diff --git a/t/17-ctl.t b/t/17-ctl.t
index ded9d63..ce22ea6 100644
--- a/t/17-ctl.t
+++ b/t/17-ctl.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 7;
+use Test::More tests => 8 + 1;
 
 use Variable::Magic qw/wizard cast/;
 
@@ -74,3 +74,8 @@ eval q{BEGIN {
 }};
 
 like $@, qr/pepperoni/, 'die in len callback in BEGIN';
+
+use lib 't/lib';
+eval "use Variable::Magic::TestDieRequired";
+
+like $@, qr/turnip/, 'die in required with localized hash gets the right error message';
diff --git a/t/lib/Variable/Magic/TestDieRequired.pm b/t/lib/Variable/Magic/TestDieRequired.pm
new file mode 100644
index 0000000..50792b1
--- /dev/null
+++ b/t/lib/Variable/Magic/TestDieRequired.pm
@@ -0,0 +1,25 @@
+package Variable::Magic::TestDieRequired;
+
+use Test::More;
+
+use Variable::Magic qw/wizard cast/;
+
+my $wiz;
+
+BEGIN {
+ $wiz = wizard
+  data => sub { $_[1] },
+  free => sub { $_[1]->(); () };
+}
+
+sub hook (&) {
+ $^H |= 0x020000;
+ cast %^H, $wiz, shift;
+}
+
+BEGIN {
+ hook { pass 'in Variable::Magic::TestRequired hook' };
+ die 'turnip';
+}
+
+1;