X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=76e88216920933deb17c06986a20112e7060d73f;hb=ed1f29a02e9894bb90bb4f3f3d42d7fe0fd3e545;hp=40997edcf1286f054f2ae457fe7f69bd1ebf9d67;hpb=b85f6ded9d3d67458fd9e3f37e0367d446e85d6a;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/Magic.xs b/Magic.xs
index 40997ed..76e8821 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -89,6 +89,10 @@ 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
@@ -101,6 +105,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define PERL_MAGIC_ext '~'
 #endif
 
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
 #ifndef MGf_COPY
 # define MGf_COPY 0
 #endif
@@ -317,6 +325,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
  MAGIC *mg = NULL, *moremagic = NULL;
  MGWIZ *w;
  SV *data;
+ U32 oldgmg = SvGMAGICAL(sv);
 
  w = SV2MGWIZ(wiz);
 
@@ -344,10 +353,21 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
   mg->mg_flags |= MGf_LOCAL;
 #endif /* MGf_LOCAL */
 
+ if (SvTYPE(sv) < SVt_PVHV)
+  goto done;
+
+ /* The GMAGICAL flag only says that a hash is tied or has uvar magic - get
+  * magic is actually never called for them. If the GMAGICAL flag was off before
+  * calling sv_magicext(), the hash isn't tied and has no uvar magic. If it's
+  * now on, then this wizard has get magic. Hence we can work around the
+  * get/clear shortcoming by turning the GMAGICAL flag off. If the current magic
+  * has uvar callbacks, it will be turned back on later. */
+ if (!oldgmg && SvGMAGICAL(sv))
+  SvGMAGICAL_off(sv);
+
 #if VMG_UVAR
- if (w->uvar && SvTYPE(sv) >= SVt_PVHV) {
+ if (w->uvar) {
   MAGIC *prevmagic;
-  int add_uvar = 1;
   struct ufuncs uf[2];
 
   uf[0].uf_val   = vmg_svt_val;
@@ -366,8 +386,8 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
   if (mg) { /* Found another uvar magic. */
    struct ufuncs *olduf = (struct ufuncs *) mg->mg_ptr;
    if (olduf->uf_val == vmg_svt_val) {
-    /* It's our uvar magic, nothing to do. */
-    add_uvar = 0;
+    /* It's our uvar magic, nothing to do. oldgmg was true. */
+    goto done;
    } else {
     /* It's another uvar magic, backup it and replace it by ours. */
     uf[1] = *olduf;
@@ -375,13 +395,13 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
    }
   }
 
-  if (add_uvar) {
-   vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
-  }
-
+  vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
+  /* Our hash now carries uvar magic. The uvar/clear shortcoming has to be
+   * handled by our uvar callback. */
  }
 #endif /* VMG_UVAR */
 
+done:
  return 1;
 }
 
@@ -530,7 +550,6 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  U32 ret;
 
  dSP;
- int count;
 
  has_array = SvTYPE(sv) == SVt_PVAV;
 
@@ -550,7 +569,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  }
  PUTBACK;
 
- count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
+ call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
 
  SPAGAIN;
  svr = POPs;
@@ -569,6 +588,7 @@ STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
 
 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  SV *wiz = (SV *) mg->mg_ptr;
+ int ret = 0;
 
  /* This may happen in global destruction */
  if (SvTYPE(wiz) == SVTYPEMASK)
@@ -586,7 +606,13 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
 
  /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
   * mg->mg_ptr reference count */
- return vmg_cb_call1e(SV2MGWIZ(wiz)->cb_free, sv, mg->mg_obj);
+ ret = vmg_cb_call1e(SV2MGWIZ(wiz)->cb_free, sv, mg->mg_obj);
+
+ /* 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);
+
+ return ret;
 }
 
 #if MGf_COPY
@@ -629,15 +655,21 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
 #endif /* MGf_LOCAL */
 
 #if VMG_UVAR
+STATIC OP *vmg_pp_resetuvar(pTHX) {
+ SvRMAGICAL_on(cSVOP_sv);
+ return NORMAL;
+}
+
 STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  struct ufuncs *uf;
- MAGIC *mg;
- SV *key = NULL;
+ MAGIC *mg, *umg;
+ SV *key = NULL, *newkey = NULL;
+ int tied = 0;
 
- mg  = mg_find(sv, PERL_MAGIC_uvar);
- /* mg can't be NULL or we wouldn't be there. */
- key = mg->mg_obj;
- uf  = (struct ufuncs *) mg->mg_ptr;
+ umg = mg_find(sv, PERL_MAGIC_uvar);
+ /* umg can't be NULL or we wouldn't be there. */
+ 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); }
@@ -645,11 +677,25 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
   MGWIZ *w;
-  if ((mg->mg_type != PERL_MAGIC_ext)
-   || (mg->mg_private < SIG_MIN)
-   || (mg->mg_private > SIG_MAX)) { continue; }
+  switch (mg->mg_type) {
+   case PERL_MAGIC_ext:
+    break;
+   case PERL_MAGIC_tied:
+    ++tied;
+    continue;
+   default:
+    continue;
+  }
+  if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX)
+   continue;
   w = SV2MGWIZ(mg->mg_ptr);
-  if (!w->uvar) { continue; }
+  switch (w->uvar) {
+   case 0:
+    continue;
+   case 2:
+    if (!newkey)
+     newkey = key = umg->mg_obj = sv_2mortal(newSVsv(umg->mg_obj));
+  }
   switch (action) {
    case 0:
     if (w->cb_fetch)  { vmg_cb_call2(w->cb_fetch,  sv, mg->mg_obj, key); }
@@ -668,6 +714,25 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
   }
  }
 
+ if (SvRMAGICAL(sv) && !tied) {
+  /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly
+   * 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 *o = PL_op;
+  if (!o->op_next || o->op_next->op_ppaddr != vmg_pp_resetuvar) {
+   SVOP *svop;
+   NewOp(1101, svop, 1, SVOP);
+   svop->op_type   = OP_STUB;
+   svop->op_ppaddr = vmg_pp_resetuvar;
+   svop->op_next   = o->op_next;
+   svop->op_flags  = 0;
+   svop->op_sv     = sv;
+   o->op_next      = (OP *) svop;
+  }
+  SvRMAGICAL_off(sv);
+ }
+
  return 0;
 }
 #endif /* VMG_UVAR */
@@ -963,7 +1028,7 @@ CODE:
               + 1
 #endif /* MGf_LOCAL */
 #if VMG_UVAR
-              + 4
+              + 5
 #endif /* VMG_UVAR */
               ) { croak(vmg_wrongargnum); }
 
@@ -1006,16 +1071,17 @@ CODE:
  VMG_SET_CB(ST(i++), store);
  VMG_SET_CB(ST(i++), exists);
  VMG_SET_CB(ST(i++), delete);
+ cb = ST(i++);
+ if (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete)
+  w->uvar = SvTRUE(cb) ? 2 : 1;
+ else
+  w->uvar = 0;
 #endif /* VMG_UVAR */
 #if VMG_MULTIPLICITY
  w->owner = aTHX;
 #endif /* VMG_MULTIPLICITY */
-
- w->vtbl = t;
- w->sig  = sig;
-#if VMG_UVAR
- w->uvar = (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete);
-#endif /* VMG_UVAR */
+ w->vtbl  = t;
+ w->sig   = sig;
 
  sv = MGWIZ2SV(w);
  mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);