Fix segfaults when using get or uvar magic simultaneously with clear magic

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

diff --git a/Magic.xs b/Magic.xs
index 0ecf6933caf6975cf3b3388152a4b25b3b63cf4a..73536b861649b32eb497cc082f611ba15e567fdc 100644 (file)
--- 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
@@ -267,14 +275,12 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
  call_sv(ctor, G_SCALAR);
 
  SPAGAIN;
-
  nsv = POPs;
 #if VMG_HAS_PERL(5, 8, 3)
  SvREFCNT_inc(nsv);    /* Or it will be destroyed in FREETMPS */
 #else
  nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
 #endif
-
  PUTBACK;
 
  FREETMPS;
@@ -346,8 +352,11 @@ 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;
+
 #if VMG_UVAR
- if (w->uvar && SvTYPE(sv) >= SVt_PVHV) {
+ if (w->uvar) {
   MAGIC *prevmagic;
   int add_uvar = 1;
   struct ufuncs uf[2];
@@ -375,15 +384,20 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
     uf[1] = *olduf;
     vmg_uvar_del(sv, prevmagic, mg, moremagic);
    }
-  }
+  } else if (w->cb_get)
+   SvGMAGICAL_off(sv);
 
   if (add_uvar) {
    vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
   }
 
  }
+#else
+ if (w->cb_get)
+  SvGMAGICAL_off(sv);
 #endif /* VMG_UVAR */
 
+done:
  return 1;
 }
 
@@ -510,7 +524,6 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
  FREETMPS;
  LEAVE;
 
-
  return ret;
 }
 
@@ -571,17 +584,32 @@ 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)
+  return 0;
+
  /* So that it can survive tmp cleanup in vmg_cb_call */
  SvREFCNT_inc(sv);
+
 #if !VMG_HAS_PERL_MAINT(5, 11, 0, 32686)
  /* The previous magic tokens were freed but the magic chain wasn't updated, so
   * if you access the sv from the callback the old deleted magics will trigger
   * and cause memory misreads. Change 32686 solved it that way : */
  SvMAGIC_set(sv, mg);
 #endif
+
  /* 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(mg->mg_ptr)->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
@@ -624,15 +652,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); }
@@ -640,11 +674,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); }
@@ -663,6 +711,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 */
@@ -673,7 +740,7 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
  char buf[8];
  MGWIZ *w;
 
- if (PL_dirty) /* during global destruction, the context is already freed */
+ if (PL_dirty) /* During global destruction, the context is already freed */
   return 0;
 
  w = SV2MGWIZ(wiz);
@@ -958,7 +1025,7 @@ CODE:
               + 1
 #endif /* MGf_LOCAL */
 #if VMG_UVAR
-              + 4
+              + 5
 #endif /* VMG_UVAR */
               ) { croak(vmg_wrongargnum); }
 
@@ -1001,16 +1068,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);