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 985b37ff1771e3fbc3984062f2963e105b138700..48c8bdd982c63981dc671ad1c447bc25965912d2 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -203,7 +203,10 @@ STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
 
 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 
-typedef HV * my_cxt_t;
+typedef struct {
+ HV *wizards;
+ HV *b__op_stash;
+} my_cxt_t;
 
 START_MY_CXT
 
@@ -224,7 +227,7 @@ STATIC U16 vmg_gensig(pTHX) {
 
  do {
   sig = SIG_NBR * Drand01() + SIG_MIN;
- } while (hv_exists(MY_CXT, buf, sprintf(buf, "%u", sig)));
+ } while (hv_exists(MY_CXT.wizards, buf, sprintf(buf, "%u", sig)));
 
  return sig;
 }
@@ -498,27 +501,28 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
 #define VMG_OP_INFO_NAME   1
 #define VMG_OP_INFO_OBJECT 2
 
-STATIC STRLEN *vmg_op_name_len = NULL;
-
-STATIC HV *vmg_b__op_stash = NULL;
+STATIC U32           vmg_op_name_init      = 0;
+STATIC unsigned char vmg_op_name_len[MAXO] = { 0 };
 
 STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) {
 #define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W))
  switch (opinfo) {
   case VMG_OP_INFO_NAME:
-   if (!vmg_op_name_len) {
+   if (!vmg_op_name_init) {
     OPCODE t;
-    Newx(vmg_op_name_len, MAXO, STRLEN);
     for (t = 0; t < OP_max; ++t)
      vmg_op_name_len[t] = strlen(PL_op_name[t]);
+    vmg_op_name_init = 1;
    }
    break;
-  case VMG_OP_INFO_OBJECT:
-   if (!vmg_b__op_stash) {
+  case VMG_OP_INFO_OBJECT: {
+   dMY_CXT;
+   if (!MY_CXT.b__op_stash) {
     require_pv("B.pm");
-    vmg_b__op_stash = gv_stashpv("B::OP", 1);
+    MY_CXT.b__op_stash = gv_stashpv("B::OP", 1);
    }
    break;
+  }
   default:
    break;
  }
@@ -534,9 +538,11 @@ STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
    OPCODE t = PL_op->op_type;
    return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t]));
   }
-  case VMG_OP_INFO_OBJECT:
+  case VMG_OP_INFO_OBJECT: {
+   dMY_CXT;
    return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))),
-                              vmg_b__op_stash);
+                              MY_CXT.b__op_stash);
+  }
   default:
    break;
  }
@@ -555,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;
@@ -581,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;
@@ -593,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;
 }
 
@@ -849,7 +873,7 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
 
  {
   dMY_CXT;
-  if (hv_delete(MY_CXT, buf, sprintf(buf, "%u", w->sig), 0) != wiz)
+  if (hv_delete(MY_CXT.wizards, buf, sprintf(buf, "%u", w->sig), 0) != wiz)
    return 0;
  }
  SvFLAGS(wiz) |= SVf_BREAK;
@@ -905,6 +929,7 @@ STATIC const char vmg_invalid_sig[]    = "Invalid numeric signature";
 STATIC const char vmg_wrongargnum[]    = "Wrong number of arguments";
 STATIC const char vmg_toomanysigs[]    = "Too many magic signatures used";
 STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
+STATIC const char vmg_globstorefail[]  = "Couldn't store global wizard information";
 
 STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
 #define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S))
@@ -940,7 +965,7 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  if (!hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))
+  if (!hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
    sig = 0;
  }
  return sig;
@@ -967,7 +992,7 @@ STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  return (old = hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))
+  return (old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
           ? *old : NULL;
  }
 }
@@ -1044,8 +1069,9 @@ BOOT:
 {
  HV *stash;
  MY_CXT_INIT;
- MY_CXT = newHV();
- hv_iterinit(MY_CXT); /* Allocate iterator */
+ MY_CXT.wizards = newHV();
+ hv_iterinit(MY_CXT.wizards); /* Allocate iterator */
+ MY_CXT.b__op_stash = NULL;
  stash = gv_stashpv(__PACKAGE__, 1);
  newCONSTSUB(stash, "SIG_MIN",   newSVuv(SIG_MIN));
  newCONSTSUB(stash, "SIG_MAX",   newSVuv(SIG_MAX));
@@ -1075,14 +1101,15 @@ CLONE(...)
 PROTOTYPE: DISABLE
 PREINIT:
  HV *hv;
+ U32 had_b__op_stash = 0;
 CODE:
  {
   HE *key;
   dMY_CXT;
   hv = newHV();
   hv_iterinit(hv); /* Allocate iterator */
-  hv_iterinit(MY_CXT);
-  while ((key = hv_iternext(MY_CXT))) {
+  hv_iterinit(MY_CXT.wizards);
+  while ((key = hv_iternext(MY_CXT.wizards))) {
    STRLEN len;
    char *sig = HePV(key, len);
    SV *sv;
@@ -1094,12 +1121,15 @@ CODE:
    mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
    mg->mg_private = SIG_WIZ;
    SvREADONLY_on(sv);
-   hv_store(hv, sig, len, sv, HeHASH(key));
+   if (!hv_store(hv, sig, len, sv, HeHASH(key))) croak("%s during CLONE", vmg_globstorefail);
   }
+  if (MY_CXT.b__op_stash)
+   had_b__op_stash = 1;
  }
  {
   MY_CXT_CLONE;
-  MY_CXT = hv;
+  MY_CXT.wizards     = hv;
+  MY_CXT.b__op_stash = had_b__op_stash ? gv_stashpv("B::OP", 1) : NULL;
  }
 
 #endif /* VMG_THREADSAFE */
@@ -1138,12 +1168,12 @@ CODE:
  if (SvOK(svsig)) {
   SV **old;
   sig = vmg_sv2sig(svsig);
-  if ((old = hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))) {
+  if ((old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))) {
    ST(0) = sv_2mortal(newRV_inc(*old));
    XSRETURN(1);
   }
  } else {
-  if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
+  if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) { croak(vmg_toomanysigs); }
   sig = vmg_gensig();
  }
  
@@ -1194,7 +1224,7 @@ CODE:
  mg->mg_private = SIG_WIZ;
  SvREADONLY_on(sv);
 
- hv_store(MY_CXT, buf, sprintf(buf, "%u", sig), sv, 0);
+ if (!hv_store(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), sv, 0)) croak(vmg_globstorefail);
 
  RETVAL = newRV_noinc(sv);
 OUTPUT:
@@ -1204,7 +1234,7 @@ SV *gensig()
 PROTOTYPE:
 CODE:
  dMY_CXT;
- if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
+ if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) { croak(vmg_toomanysigs); }
  RETVAL = newSVuv(vmg_gensig());
 OUTPUT:
  RETVAL
@@ -1242,12 +1272,13 @@ CODE:
 OUTPUT:
  RETVAL
 
-SV *getdata(SV *sv, SV *wiz)
+void
+getdata(SV *sv, SV *wiz)
 PROTOTYPE: \[$@%&*]$
 PREINIT:
  SV *data;
  U16 sig;
-CODE:
+PPCODE:
  sig = vmg_wizard_sig(wiz);
  if (!sig)
   XSRETURN_UNDEF;
@@ -1267,13 +1298,3 @@ CODE:
  RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig));
 OUTPUT:
  RETVAL
-
-void
-_cleanup()
-PROTOTYPE:
-PPCODE:
- if (vmg_op_name_len) {
-  Safefree(vmg_op_name_len);
-  vmg_op_name_len = NULL;
- }
- XSRETURN(0);