Fix and test segfaults and wrong "Unknown error" exceptions when dieing in require...

[perl/modules/Variable-Magic.git] / Magic.xs

diff --git a/Magic.xs b/Magic.xs
index f034a280440aecd63b249819f5665606db2fc9d1..48c8bdd982c63981dc671ad1c447bc25965912d2 100644 (file)
--- 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;
 }