X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=1091f15dd71dd88d73b656e4149617d6f0423fc0;hb=982fc8481dd6fa6e256a6b829f13a26a9e703271;hp=24f8d5c97da6aa091ef6a5386c159a676b1ce803;hpb=f80e249f673c39ee8ba0dd58b26a3d5384448b61;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/Magic.xs b/Magic.xs
index 24f8d5c..1091f15 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -401,7 +401,9 @@ STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 
 typedef struct {
- HV *b__op_stashes[OPc_MAX];
+ HV    *b__op_stashes[OPc_MAX];
+ I32    depth;
+ MAGIC *freed_tokens;
 } my_cxt_t;
 
 START_MY_CXT
@@ -755,6 +757,7 @@ STATIC SV *vmg_data_get(pTHX_ SV *sv, const vmg_wizard *w) {
 /* ... Magic cast/dispell .................................................. */
 
 #if VMG_UVAR
+
 STATIC I32 vmg_svt_val(pTHX_ IV, SV *);
 
 typedef struct {
@@ -762,18 +765,61 @@ typedef struct {
  struct ufuncs old_uf;
 } vmg_uvar_ud;
 
-STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) {
- if (prevmagic) {
+#endif /* VMG_UVAR */
+
+STATIC void vmg_mg_del(pTHX_ SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) {
+#define vmg_mg_del(S, P, M, N) vmg_mg_del(aTHX_ (S), (P), (M), (N))
+ dMY_CXT;
+
+ if (prevmagic)
   prevmagic->mg_moremagic = moremagic;
- } else {
+ else
   SvMAGIC_set(sv, moremagic);
+
+ /* Destroy private data */
+#if VMG_UVAR
+ if (mg->mg_type == PERL_MAGIC_uvar) {
+  Safefree(mg->mg_ptr);
+ } else {
+#endif /* VMG_UVAR */
+  if (mg->mg_obj != sv) {
+   SvREFCNT_dec(mg->mg_obj);
+   mg->mg_obj = NULL;
+  }
+  /* Unreference the wizard */
+  SvREFCNT_dec((SV *) mg->mg_ptr);
+  mg->mg_ptr = NULL;
+#if VMG_UVAR
  }
- mg->mg_moremagic = NULL;
- Safefree(mg->mg_ptr);
- Safefree(mg);
-}
 #endif /* VMG_UVAR */
 
+ if (MY_CXT.depth) {
+  mg->mg_moremagic    = MY_CXT.freed_tokens;
+  MY_CXT.freed_tokens = mg;
+ } else {
+  mg->mg_moremagic = NULL;
+  Safefree(mg);
+ }
+}
+
+STATIC int vmg_magic_chain_free(pTHX_ MAGIC *mg, MAGIC *skip) {
+#define vmg_magic_chain_free(M, S) vmg_magic_chain_free(aTHX_ (M), (S))
+ int skipped = 0;
+
+ while (mg) {
+  MAGIC *moremagic = mg->mg_moremagic;
+
+  if (mg == skip)
+   ++skipped;
+  else
+   Safefree(mg);
+
+  mg = moremagic;
+ }
+
+ return skipped;
+}
+
 STATIC UV vmg_cast(pTHX_ SV *sv, const vmg_wizard *w, const SV *wiz, SV **args, I32 items) {
 #define vmg_cast(S, W, WIZ, A, I) vmg_cast(aTHX_ (S), (W), (WIZ), (A), (I))
  MAGIC  *mg;
@@ -845,7 +891,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, const vmg_wizard *w, const SV *wiz, SV **args,
    } else {
     /* It's another uvar magic, backup it and replace it by ours. */
     ud.old_uf = *uf;
-    vmg_uvar_del(sv, prevmagic, mg, moremagic);
+    vmg_mg_del(sv, prevmagic, mg, moremagic);
    }
   }
 
@@ -898,19 +944,7 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, const vmg_wizard *w) {
  if (!mg)
   return 0;
 
- if (prevmagic) {
-  prevmagic->mg_moremagic = moremagic;
- } else {
-  SvMAGIC_set(sv, moremagic);
- }
- mg->mg_moremagic = NULL;
-
- /* Destroy private data */
- if (mg->mg_obj != sv)
-  SvREFCNT_dec(mg->mg_obj);
- /* Unreference the wizard */
- SvREFCNT_dec((SV *) mg->mg_ptr);
- Safefree(mg);
+ vmg_mg_del(sv, prevmagic, mg, moremagic);
 
 #if VMG_UVAR
  if (uvars == 1 && SvTYPE(sv) >= SVt_PVHV) {
@@ -945,7 +979,7 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, const vmg_wizard *w) {
     mg->mg_len = sizeof(*uf);
    } else {
     /* Remove the uvar magic. */
-    vmg_uvar_del(sv, prevmagic, mg, moremagic);
+    vmg_mg_del(sv, prevmagic, mg, moremagic);
    }
   }
  }
@@ -1022,12 +1056,77 @@ STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
 
 #define VMG_CB_CALL_ARGS_MASK  15
 #define VMG_CB_CALL_ARGS_SHIFT 4
-#define VMG_CB_CALL_OPINFO     (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT)
+#define VMG_CB_CALL_OPINFO     (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT) /* 1|2 */
+#define VMG_CB_CALL_GUARD      4
+
+STATIC int vmg_dispell_guard_oncroak(pTHX_ void *ud) {
+ dMY_CXT;
+
+ MY_CXT.depth--;
+
+ /* If we're at the upmost magic call and we're about to die, we can just free
+  * the tokens right now, since we will jump past the problematic part of our
+  * caller. */
+ if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) {
+  vmg_magic_chain_free(MY_CXT.freed_tokens, NULL);
+  MY_CXT.freed_tokens = NULL;
+ }
+
+ return 1;
+}
+
+STATIC int vmg_dispell_guard_free(pTHX_ SV *sv, MAGIC *mg) {
+ vmg_magic_chain_free((MAGIC *) mg->mg_ptr, NULL);
+
+ return 0;
+}
+
+#if VMG_THREADSAFE
+
+STATIC int vmg_dispell_guard_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) {
+ /* The freed magic tokens aren't cloned by perl because it cannot reach them
+  * (they have been detached from their parent SV when they were enqueued).
+  * Hence there's nothing to purge in the new thread. */
+ mg->mg_ptr = NULL;
+
+ return 0;
+}
+
+#endif /* VMG_THREADSAFE */
+
+STATIC MGVTBL vmg_dispell_guard_vtbl = {
+ NULL,                   /* get */
+ NULL,                   /* set */
+ NULL,                   /* len */
+ NULL,                   /* clear */
+ vmg_dispell_guard_free, /* free */
+ NULL,                   /* copy */
+#if VMG_THREADSAFE
+ vmg_dispell_guard_dup,  /* dup */
+#else
+ NULL,                   /* dup */
+#endif
+#if MGf_LOCAL
+ NULL,                   /* local */
+#endif /* MGf_LOCAL */
+};
+
+STATIC SV *vmg_dispell_guard_new(pTHX_ MAGIC *root) {
+#define vmg_dispell_guard_new(R) vmg_dispell_guard_new(aTHX_ (R))
+ SV *guard;
+
+ guard = sv_newmortal();
+ sv_magicext(guard, NULL, PERL_MAGIC_ext, &vmg_dispell_guard_vtbl,
+                          (char *) root, 0);
+
+ return guard;
+}
 
 STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
  va_list ap;
  int ret = 0;
  unsigned int i, args, opinfo;
+ MAGIC **chain = NULL;
  SV *svr;
 
  dSP;
@@ -1052,7 +1151,16 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
   XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
- vmg_call_sv(cb, G_SCALAR, 0, NULL);
+ if (flags & VMG_CB_CALL_GUARD) {
+  dMY_CXT;
+  MY_CXT.depth++;
+  vmg_call_sv(cb, G_SCALAR, vmg_dispell_guard_oncroak, NULL);
+  MY_CXT.depth--;
+  if (MY_CXT.depth == 0 && MY_CXT.freed_tokens)
+   chain = &MY_CXT.freed_tokens;
+ } else {
+  vmg_call_sv(cb, G_SCALAR, 0, NULL);
+ }
 
  SPAGAIN;
  svr = POPs;
@@ -1063,6 +1171,11 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
  FREETMPS;
  LEAVE;
 
+ if (chain) {
+  vmg_dispell_guard_new(*chain);
+  *chain = NULL;
+ }
+
  return ret;
 }
 
@@ -1076,6 +1189,8 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
 #define vmg_cb_call3(I, OI, S, A1, A2, A3) \
         vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 3), (S), (A1), (A2), (A3))
 
+/* ... Default no-op magic callback ........................................ */
+
 STATIC int vmg_svt_default_noop(pTHX_ SV *sv, MAGIC *mg) {
  return 0;
 }
@@ -1176,8 +1291,13 @@ STATIC U32 vmg_svt_len_noop(pTHX_ SV *sv, MAGIC *mg) {
 
 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
  const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
+ unsigned int flags  = w->opinfo;
+
+#if !VMG_HAS_PERL(5, 12, 0)
+ flags |= VMG_CB_CALL_GUARD;
+#endif
 
- return vmg_cb_call1(w->cb_clear, w->opinfo, sv, mg->mg_obj);
+ return vmg_cb_call1(w->cb_clear, flags, sv, mg->mg_obj);
 }
 
 #define vmg_svt_clear_noop vmg_svt_default_noop
@@ -1191,16 +1311,14 @@ STATIC int vmg_svt_free_cleanup(pTHX_ void *ud) {
  /* We are about to croak() while sv is being destroyed. Try to clean up
   * things a bit. */
  mg = SvMAGIC(sv);
- SvREFCNT_dec((SV *) mg->mg_ptr);
- /* mg->mg_obj may not be refcounted if the data constructor returned the
-  * variable itself. */
- if (mg->mg_flags & MGf_REFCOUNTED)
-  SvREFCNT_dec(mg->mg_obj);
- SvMAGIC_set(sv, mg->mg_moremagic);
- Safefree(mg);
- mg_magical(sv);
+ if (mg) {
+  vmg_mg_del(sv, NULL, mg, mg->mg_moremagic);
+  mg_magical(sv);
+ }
  SvREFCNT_dec(sv);
 
+ vmg_dispell_guard_oncroak(aTHX_ ud);
+
  /* After that, propagate the error upwards. */
  return 1;
 }
@@ -1240,7 +1358,18 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
   XPUSHs(vmg_op_info(w->opinfo));
  PUTBACK;
 
- vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, sv);
+ {
+  dMY_CXT;
+  MY_CXT.depth++;
+  vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, sv);
+  MY_CXT.depth--;
+  if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) {
+   /* Free all the tokens in the chain but the current one (if it's present).
+    * It will be taken care of by our caller, Perl_mg_free(). */
+   vmg_magic_chain_free(MY_CXT.freed_tokens, mg);
+   MY_CXT.freed_tokens = NULL;
+  }
+ }
 
  SPAGAIN;
  svr = POPs;
@@ -1320,14 +1449,19 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
 /* ... uvar magic .......................................................... */
 
 #if VMG_UVAR
-STATIC OP *vmg_pp_resetuvar(pTHX) {
- SvRMAGICAL_on(cSVOP_sv);
+
+STATIC OP *vmg_pp_reset_rmg(pTHX) {
+ SVOP *o = cSVOPx(PL_op);
+
+ SvRMAGICAL_on(o->op_sv);
+ o->op_sv = NULL;
+
  return NORMAL;
 }
 
 STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  vmg_uvar_ud *ud;
- MAGIC *mg, *umg;
+ MAGIC *mg, *umg, *moremagic;
  SV *key = NULL, *newkey = NULL;
  int tied = 0;
 
@@ -1341,9 +1475,13 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  if (ud->old_uf.uf_set)
   ud->old_uf.uf_set(aTHX_ action, sv);
 
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ for (mg = SvMAGIC(sv); mg; mg = moremagic) {
   const vmg_wizard *w;
 
+  /* mg may be freed later by the uvar call, so we need to fetch the next
+   * token before reaching that fateful point. */
+  moremagic = mg->mg_moremagic;
+
   switch (mg->mg_type) {
    case PERL_MAGIC_ext:
     break;
@@ -1370,21 +1508,25 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
              & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS|HV_FETCH_LVALUE|HV_DELETE)) {
    case 0:
     if (w->cb_fetch)
-     vmg_cb_call2(w->cb_fetch, w->opinfo, sv, mg->mg_obj, key);
+     vmg_cb_call2(w->cb_fetch, w->opinfo | VMG_CB_CALL_GUARD, sv,
+                               mg->mg_obj, key);
     break;
    case HV_FETCH_ISSTORE:
    case HV_FETCH_LVALUE:
    case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE):
     if (w->cb_store)
-     vmg_cb_call2(w->cb_store, w->opinfo, sv, mg->mg_obj, key);
+     vmg_cb_call2(w->cb_store, w->opinfo | VMG_CB_CALL_GUARD, sv,
+                               mg->mg_obj, key);
     break;
    case HV_FETCH_ISEXISTS:
     if (w->cb_exists)
-     vmg_cb_call2(w->cb_exists, w->opinfo, sv, mg->mg_obj, key);
+     vmg_cb_call2(w->cb_exists, w->opinfo | VMG_CB_CALL_GUARD, sv,
+                                mg->mg_obj, key);
     break;
    case HV_DELETE:
     if (w->cb_delete)
-     vmg_cb_call2(w->cb_delete, w->opinfo, sv, mg->mg_obj, key);
+     vmg_cb_call2(w->cb_delete, w->opinfo | VMG_CB_CALL_GUARD, sv,
+                                mg->mg_obj, key);
     break;
   }
  }
@@ -1394,22 +1536,30 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
    * mistaken for a tied hash by the rest of hv_common. It will be reset by
    * the op_ppaddr of a new fake op injected between the current and the next
    * one. */
-  OP *nop = PL_op->op_next;
-  if (!nop || nop->op_ppaddr != vmg_pp_resetuvar) {
-   SVOP *svop;
+  OP   *nop  = PL_op->op_next;
+  SVOP *svop = NULL;
+
+  if (nop && nop->op_ppaddr == vmg_pp_reset_rmg) {
+   svop = (SVOP *) nop;
+  } else {
    NewOp(1101, svop, 1, SVOP);
-   svop->op_type   = OP_STUB;
-   svop->op_ppaddr = vmg_pp_resetuvar;
-   svop->op_next   = nop;
-   svop->op_flags  = 0;
-   svop->op_sv     = sv;
-   PL_op->op_next  = (OP *) svop;
+   svop->op_type    = OP_STUB;
+   svop->op_ppaddr  = vmg_pp_reset_rmg;
+   svop->op_next    = nop;
+   svop->op_flags   = 0;
+   svop->op_private = 0;
+
+   PL_op->op_next = (OP *) svop;
   }
+
+  svop->op_sv = sv;
+
   SvRMAGICAL_off(sv);
  }
 
  return 0;
 }
+
 #endif /* VMG_UVAR */
 
 /* --- Macros for the XS section ------------------------------------------- */
@@ -1469,6 +1619,8 @@ BOOT:
  MY_CXT_INIT;
  for (c = OPc_NULL; c < OPc_MAX; ++c)
   MY_CXT.b__op_stashes[c] = NULL;
+ MY_CXT.depth        = 0;
+ MY_CXT.freed_tokens = NULL;
 #if VMG_THREADSAFE
  MUTEX_INIT(&vmg_vtable_refcount_mutex);
  MUTEX_INIT(&vmg_op_name_init_mutex);
@@ -1506,6 +1658,7 @@ CLONE(...)
 PROTOTYPE: DISABLE
 PREINIT:
  U32 had_b__op_stash = 0;
+ I32 old_depth;
  int c;
 PPCODE:
  {
@@ -1514,6 +1667,7 @@ PPCODE:
    if (MY_CXT.b__op_stashes[c])
     had_b__op_stash |= (((U32) 1) << c);
   }
+  old_depth = MY_CXT.depth;
  }
  {
   MY_CXT_CLONE;
@@ -1521,6 +1675,8 @@ PPCODE:
    MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c))
                               ? gv_stashpv(vmg_opclassnames[c], 1) : NULL;
   }
+  MY_CXT.depth        = old_depth;
+  MY_CXT.freed_tokens = NULL;
  }
  XSRETURN(0);
 
@@ -1582,7 +1738,6 @@ PROTOTYPE: \[$@%&*]$@
 PREINIT:
  const vmg_wizard *w = NULL;
  SV **args = NULL;
- UV ret;
  I32 i = 0;
 CODE:
  if (items > 2) {