X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=1dada023c031867f619d812dc50bdc76facc7a78;hb=1ff75d21f8a370b6533873480725f78eebd70efc;hp=1fa63548e2a8bf86143010a61241fa57f3b57dfe;hpb=bc19b982e9997eb17ddf75dc235c0c6ac52d07bf;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/Magic.xs b/Magic.xs
index 1fa6354..1dada02 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -36,6 +36,11 @@
 # define dNOOP
 #endif
 
+/* Safe unless stated otherwise in Makefile.PL */
+#ifndef VMG_FORKSAFE
+# define VMG_FORKSAFE 1
+#endif
+
 #ifndef VMG_MULTIPLICITY
 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
 #  define VMG_MULTIPLICITY 1
@@ -89,10 +94,6 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define Newx(v, n, c) New(0, v, n, c)
 #endif
 
-#ifndef NewOp
-# define NewOp(m, var, c, type) Newz(m, var, c, type)
-#endif
-
 #ifndef SvMAGIC_set
 # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
 #endif
@@ -139,8 +140,9 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # endif
 #endif
 
-/* uvar magic and Hash::Util::FieldHash were commited with 28419 */
-#if VMG_HAS_PERL_MAINT(5, 9, 4, 28419) || VMG_HAS_PERL(5, 10, 0)
+/* uvar magic and Hash::Util::FieldHash were commited with 28419, but only
+ * enable it on 5.10 */
+#if VMG_HAS_PERL(5, 10, 0)
 # define VMG_UVAR 1
 #else
 # define VMG_UVAR 0
@@ -233,8 +235,10 @@ STATIC const char *const vmg_opclassnames[] = {
 };
 
 STATIC opclass vmg_opclass(const OP *o) {
+#if 0
  if (!o)
   return OPc_NULL;
+#endif
 
  if (o->op_type == 0)
   return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
@@ -339,8 +343,7 @@ STATIC U16 vmg_gensig(pTHX) {
  char buf[8];
  dMY_CXT;
 
- if (HvKEYS(MY_CXT.wizards) >= SIG_NBR)
-  croak(vmg_toomanysigs);
+ if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) croak(vmg_toomanysigs);
 
  do {
   sig = SIG_NBR * Drand01() + SIG_MIN;
@@ -517,7 +520,8 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
   /* One uvar magic in the chain is enough. */
   for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
    moremagic = mg->mg_moremagic;
-   if (mg->mg_type == PERL_MAGIC_uvar) { break; }
+   if (mg->mg_type == PERL_MAGIC_uvar)
+    break;
   }
 
   if (mg) { /* Found another uvar magic. */
@@ -549,7 +553,8 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
 #endif /* VMG_UVAR */
  MAGIC *mg, *prevmagic, *moremagic = NULL;
 
- if (SvTYPE(sv) < SVt_PVMG) { return 0; }
+ if (SvTYPE(sv) < SVt_PVMG)
+  return 0;
 
  for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
   moremagic = mg->mg_moremagic;
@@ -569,7 +574,8 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
    }
   }
  }
- if (!mg) { return 0; }
+ if (!mg)
+  return 0;
 
  if (prevmagic) {
   prevmagic->mg_moremagic = moremagic;
@@ -578,8 +584,11 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
  }
  mg->mg_moremagic = NULL;
 
- if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); } /* Destroy private data */
- SvREFCNT_dec((SV *) mg->mg_ptr); /* Unreference the wizard */
+ /* Destroy private data */
+ if (mg->mg_obj != sv)
+  SvREFCNT_dec(mg->mg_obj);
+ /* Unreference the wizard */
+ SvREFCNT_dec((SV *) mg->mg_ptr);
  Safefree(mg);
 
 #if VMG_UVAR
@@ -600,7 +609,8 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
    struct ufuncs *uf;
    for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){
     moremagic = mg->mg_moremagic;
-    if (mg->mg_type == PERL_MAGIC_uvar) { break; }
+    if (mg->mg_type == PERL_MAGIC_uvar)
+     break;
    }
    /* assert(mg); */
    uf = (struct ufuncs *) mg->mg_ptr;
@@ -627,6 +637,10 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
 #define VMG_OP_INFO_NAME   1
 #define VMG_OP_INFO_OBJECT 2
 
+#if VMG_THREADSAFE
+STATIC perl_mutex vmg_op_name_init_mutex;
+#endif
+
 STATIC U32           vmg_op_name_init      = 0;
 STATIC unsigned char vmg_op_name_len[MAXO] = { 0 };
 
@@ -634,12 +648,18 @@ 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_THREADSAFE
+   MUTEX_LOCK(&vmg_op_name_init_mutex);
+#endif
    if (!vmg_op_name_init) {
     OPCODE t;
     for (t = 0; t < OP_max; ++t)
      vmg_op_name_len[t] = strlen(PL_op_name[t]);
     vmg_op_name_init = 1;
    }
+#if VMG_THREADSAFE
+   MUTEX_UNLOCK(&vmg_op_name_init_mutex);
+#endif
    break;
   case VMG_OP_INFO_OBJECT: {
    dMY_CXT;
@@ -798,6 +818,10 @@ 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, 9, 5)
+ PERL_CONTEXT saved_cx;
+ I32 cxix;
+#endif
  unsigned int had_err, has_err, flags = G_SCALAR | G_EVAL;
  int ret = 0;
 
@@ -835,8 +859,23 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  if (had_err)
   flags |= G_KEEPERR;
 
+#if VMG_HAS_PERL(5, 9, 5)
+ /* 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)
+  cxix = cxstack_ix + 1;
+ else
+  cxix = Perl_cxinc(aTHX);
+ saved_cx = cxstack[cxix];
+#endif
+
  call_sv(w->cb_free, flags);
 
+#if VMG_HAS_PERL(5, 9, 5)
+ cxstack[cxix] = saved_cx;
+#endif
+
  has_err = SvTRUE(ERRSV);
  if (IN_PERL_COMPILETIME && !had_err && has_err)
   ++PL_error_count;
@@ -846,15 +885,6 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  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));
- }
-
  /* Calling SvREFCNT_dec() will trigger destructors in an infinite loop, so
   * we have to rely on SvREFCNT() being a lvalue. Heck, even the core does it */
  --SvREFCNT(sv);
@@ -922,8 +952,10 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  key = umg->mg_obj;
  uf  = (struct ufuncs *) umg->mg_ptr;
 
- if (uf[1].uf_val != NULL) { uf[1].uf_val(aTHX_ action, sv); }
- if (uf[1].uf_set != NULL) { uf[1].uf_set(aTHX_ action, sv); }
+ if (uf[1].uf_val)
+  uf[1].uf_val(aTHX_ action, sv);
+ if (uf[1].uf_set)
+  uf[1].uf_set(aTHX_ action, sv);
 
  action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
@@ -1012,29 +1044,37 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
   if (hv_delete(MY_CXT.wizards, buf, sprintf(buf, "%u", w->sig), 0) != wiz)
    return 0;
  }
- SvFLAGS(wiz) |= SVf_BREAK;
- FREETMPS;
 
- if (w->cb_data  != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); }
- if (w->cb_get   != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); }
- if (w->cb_set   != NULL) { SvREFCNT_dec(SvRV(w->cb_set)); }
- if (w->cb_len   != NULL) { SvREFCNT_dec(SvRV(w->cb_len)); }
- if (w->cb_clear != NULL) { SvREFCNT_dec(SvRV(w->cb_clear)); }
- if (w->cb_free  != NULL) { SvREFCNT_dec(SvRV(w->cb_free)); }
+ /* Unmortalize the wizard to avoid it being freed in weird places. */
+ if (SvTEMP(wiz) && !SvREFCNT(wiz)) {
+  const I32 myfloor = PL_tmps_floor;
+  I32 i;
+  for (i = PL_tmps_ix; i > myfloor; --i) {
+   if (PL_tmps_stack[i] == wiz)
+    PL_tmps_stack[i] = NULL;
+  }
+ }
+
+ if (w->cb_data)   SvREFCNT_dec(SvRV(w->cb_data));
+ if (w->cb_get)    SvREFCNT_dec(SvRV(w->cb_get));
+ if (w->cb_set)    SvREFCNT_dec(SvRV(w->cb_set));
+ if (w->cb_len)    SvREFCNT_dec(SvRV(w->cb_len));
+ if (w->cb_clear)  SvREFCNT_dec(SvRV(w->cb_clear));
+ if (w->cb_free)   SvREFCNT_dec(SvRV(w->cb_free));
 #if MGf_COPY
- if (w->cb_copy  != NULL) { SvREFCNT_dec(SvRV(w->cb_copy)); }
+ if (w->cb_copy)   SvREFCNT_dec(SvRV(w->cb_copy));
 #endif /* MGf_COPY */
 #if 0 /* MGf_DUP */
- if (w->cb_dup   != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); }
+ if (w->cb_dup)    SvREFCNT_dec(SvRV(w->cb_dup));
 #endif /* MGf_DUP */
 #if MGf_LOCAL
- if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); }
+ if (w->cb_local)  SvREFCNT_dec(SvRV(w->cb_local));
 #endif /* MGf_LOCAL */
 #if VMG_UVAR
- if (w->cb_fetch  != NULL) { SvREFCNT_dec(SvRV(w->cb_fetch)); }
- if (w->cb_store  != NULL) { SvREFCNT_dec(SvRV(w->cb_store)); }
- if (w->cb_exists != NULL) { SvREFCNT_dec(SvRV(w->cb_exists)); }
- if (w->cb_delete != NULL) { SvREFCNT_dec(SvRV(w->cb_delete)); }
+ if (w->cb_fetch)  SvREFCNT_dec(SvRV(w->cb_fetch));
+ if (w->cb_store)  SvREFCNT_dec(SvRV(w->cb_store));
+ if (w->cb_exists) SvREFCNT_dec(SvRV(w->cb_exists));
+ if (w->cb_delete) SvREFCNT_dec(SvRV(w->cb_delete));
 #endif /* VMG_UVAR */
 
  Safefree(w->vtbl);
@@ -1082,7 +1122,6 @@ STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
 
 STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 #define vmg_wizard_sig(W) vmg_wizard_sig(aTHX_ (W))
- char buf[8];
  U16 sig;
 
  if (SvROK(wiz)) {
@@ -1095,7 +1134,9 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  if (!hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
+  char buf[8];
+  SV **old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+  if (!(old && SV2MGWIZ(*old)))
    croak(vmg_invalid_wiz);
  }
 
@@ -1104,8 +1145,6 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 
 STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
 #define vmg_wizard_wiz(W) vmg_wizard_wiz(aTHX_ (W))
- char buf[8];
- SV **old;
  U16 sig;
 
  if (SvROK(wiz)) {
@@ -1123,8 +1162,12 @@ STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  return (old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
-          ? *old : NULL;
+  char buf[8];
+  SV **old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+  if (!(old && SV2MGWIZ(*old)))
+   croak(vmg_invalid_wiz);
+
+  return *old;
  }
 }
 
@@ -1203,6 +1246,10 @@ BOOT:
  MY_CXT.wizards = newHV();
  hv_iterinit(MY_CXT.wizards); /* Allocate iterator */
  MY_CXT.b__op_stashes[0] = NULL;
+#if VMG_THREADSAFE
+ MUTEX_INIT(&vmg_op_name_init_mutex);
+#endif
+
  stash = gv_stashpv(__PACKAGE__, 1);
  newCONSTSUB(stash, "SIG_MIN",   newSVuv(SIG_MIN));
  newCONSTSUB(stash, "SIG_MAX",   newSVuv(SIG_MAX));
@@ -1221,6 +1268,7 @@ BOOT:
                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
  newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
  newCONSTSUB(stash, "VMG_THREADSAFE",      newSVuv(VMG_THREADSAFE));
+ newCONSTSUB(stash, "VMG_FORKSAFE",        newSVuv(VMG_FORKSAFE));
  newCONSTSUB(stash, "VMG_OP_INFO_NAME",    newSVuv(VMG_OP_INFO_NAME));
  newCONSTSUB(stash, "VMG_OP_INFO_OBJECT",  newSVuv(VMG_OP_INFO_OBJECT));
 }
@@ -1245,13 +1293,16 @@ CODE:
    STRLEN len;
    char *sig = HePV(key, len);
    SV *sv;
-   const MGWIZ *w;
-   MAGIC *mg;
-   w  = SV2MGWIZ(HeVAL(key));
-   w  = vmg_wizard_clone(w);
-   sv = MGWIZ2SV(w);
-   mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
-   mg->mg_private = SIG_WZO;
+   const MGWIZ *w = SV2MGWIZ(HeVAL(key));
+   if (w) {
+    MAGIC *mg;
+    w  = vmg_wizard_clone(w);
+    sv = MGWIZ2SV(w);
+    mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
+    mg->mg_private = SIG_WZO;
+   } else {
+    sv = MGWIZ2SV(NULL);
+   }
    SvREADONLY_on(sv);
    if (!hv_store(hv, sig, len, sv, HeHASH(key))) croak("%s during CLONE", vmg_globstorefail);
   }
@@ -1305,7 +1356,8 @@ CODE:
  if (SvOK(svsig)) {
   SV **old;
   sig = vmg_sv2sig(svsig);
-  if ((old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))) {
+  old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+  if (old && SV2MGWIZ(*old)) {
    ST(0) = sv_2mortal(newRV_inc(*old));
    XSRETURN(1);
   }
@@ -1368,16 +1420,24 @@ OUTPUT:
 
 SV *gensig()
 PROTOTYPE:
+PREINIT:
+ U16 sig;
+ char buf[8];
 CODE:
- RETVAL = newSVuv(vmg_gensig());
+ dMY_CXT;
+ sig = vmg_gensig();
+ if (!hv_store(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), MGWIZ2SV(NULL), 0)) croak(vmg_globstorefail);
+ RETVAL = newSVuv(sig);
 OUTPUT:
  RETVAL
 
 SV *getsig(SV *wiz)
 PROTOTYPE: $
+PREINIT:
+ U16 sig;
 CODE:
- if (!SvROK(wiz)) { croak(vmg_invalid_wiz); }
- RETVAL = newSVuv(SV2MGWIZ(SvRV(wiz))->sig);
+ sig = vmg_wizard_sig(wiz);
+ RETVAL = newSVuv(sig);
 OUTPUT:
  RETVAL
 
@@ -1388,8 +1448,6 @@ PREINIT:
  SV *ret;
 CODE:
  wiz = vmg_wizard_wiz(wiz);
- if (!wiz)
-  XSRETURN_UNDEF;
  if (items > 2) {
   I32 i;
   args = newAV();
@@ -1397,7 +1455,7 @@ CODE:
   for (i = 2; i < items; ++i) {
    SV *arg = ST(i);
    SvREFCNT_inc(arg);
-   if (av_store(args, i - 2, arg) == NULL) { croak(vmg_argstorefailed); }
+   if (av_store(args, i - 2, arg) == NULL) croak(vmg_argstorefailed);
   }
  }
  ret = newSVuv(vmg_cast(SvRV(sv), wiz, args));
@@ -1415,7 +1473,8 @@ PREINIT:
 PPCODE:
  sig  = vmg_wizard_sig(wiz);
  data = vmg_data_get(SvRV(sv), sig);
- if (!data) { XSRETURN_UNDEF; }
+ if (!data)
+  XSRETURN_EMPTY;
  ST(0) = data;
  XSRETURN(1);