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

diff --git a/Magic.xs b/Magic.xs
index e474114..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
@@ -101,6 +102,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
 #endif
 
+#ifndef SvPV_const
+# define SvPV_const SvPV
+#endif
+
 #ifndef PERL_MAGIC_ext
 # define PERL_MAGIC_ext '~'
 #endif
@@ -135,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
@@ -195,20 +201,139 @@ STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
 
 #endif /* VMG_UVAR */
 
+/* --- Stolen chunk of B --------------------------------------------------- */
+
+typedef enum {
+ OPc_NULL   = 0,
+ OPc_BASEOP = 1,
+ OPc_UNOP   = 2,
+ OPc_BINOP  = 3,
+ OPc_LOGOP  = 4,
+ OPc_LISTOP = 5,
+ OPc_PMOP   = 6,
+ OPc_SVOP   = 7,
+ OPc_PADOP  = 8,
+ OPc_PVOP   = 9,
+ OPc_LOOP   = 10,
+ OPc_COP    = 11,
+ OPc_MAX    = 12
+} opclass;
+
+STATIC const char *const vmg_opclassnames[] = {
+ "B::NULL",
+ "B::OP",
+ "B::UNOP",
+ "B::BINOP",
+ "B::LOGOP",
+ "B::LISTOP",
+ "B::PMOP",
+ "B::SVOP",
+ "B::PADOP",
+ "B::PVOP",
+ "B::LOOP",
+ "B::COP"
+};
+
+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;
+
+ if (o->op_type == OP_SASSIGN)
+  return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+
+ if (o->op_type == OP_AELEMFAST) {
+  if (o->op_flags & OPf_SPECIAL)
+   return OPc_BASEOP;
+  else
+#ifdef USE_ITHREADS
+   return OPc_PADOP;
+#else
+   return OPc_SVOP;
+#endif
+ }
+
+#ifdef USE_ITHREADS
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_RCATLINE)
+  return OPc_PADOP;
+#endif
+
+ switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+  case OA_BASEOP:
+   return OPc_BASEOP;
+  case OA_UNOP:
+   return OPc_UNOP;
+  case OA_BINOP:
+   return OPc_BINOP;
+  case OA_LOGOP:
+   return OPc_LOGOP;
+  case OA_LISTOP:
+   return OPc_LISTOP;
+  case OA_PMOP:
+   return OPc_PMOP;
+  case OA_SVOP:
+   return OPc_SVOP;
+  case OA_PADOP:
+   return OPc_PADOP;
+  case OA_PVOP_OR_SVOP:
+   return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) ? OPc_SVOP : OPc_PVOP;
+  case OA_LOOP:
+   return OPc_LOOP;
+  case OA_COP:
+   return OPc_COP;
+  case OA_BASEOP_OR_UNOP:
+   return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+  case OA_FILESTATOP:
+   return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+#ifdef USE_ITHREADS
+           (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
+#else
+           (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
+#endif
+  case OA_LOOPEXOP:
+   if (o->op_flags & OPf_STACKED)
+    return OPc_UNOP;
+   else if (o->op_flags & OPf_SPECIAL)
+    return OPc_BASEOP;
+   else
+    return OPc_PVOP;
+ }
+
+ return OPc_BASEOP;
+}
+
 /* --- Context-safe global data -------------------------------------------- */
 
 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 
-typedef HV * my_cxt_t;
+typedef struct {
+ HV *wizards;
+ HV *b__op_stashes[OPc_MAX];
+} my_cxt_t;
 
 START_MY_CXT
 
+/* --- Error messages ------------------------------------------------------ */
+
+STATIC const char vmg_invalid_wiz[]    = "Invalid wizard object";
+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";
+
 /* --- Signatures ---------------------------------------------------------- */
 
-#define SIG_MIN ((U16) (1u << 8))
+#define SIG_MIN ((U16) 0u)
 #define SIG_MAX ((U16) ((1u << 16) - 1))
 #define SIG_NBR (SIG_MAX - SIG_MIN + 1)
-#define SIG_WIZ ((U16) ((1u << 8) - 1))
+
+#define SIG_WZO ((U16) (0x3891))
+#define SIG_WIZ ((U16) (0x3892))
 
 /* ... Generate signatures ................................................. */
 
@@ -218,9 +343,11 @@ STATIC U16 vmg_gensig(pTHX) {
  char buf[8];
  dMY_CXT;
 
+ if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) croak(vmg_toomanysigs);
+
  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;
 }
@@ -229,8 +356,11 @@ STATIC U16 vmg_gensig(pTHX) {
 
 typedef struct {
  MGVTBL *vtbl;
+
  U16 sig;
- U16 uvar;
+ U8 uvar;
+ U8 opinfo;
+
  SV *cb_data;
  SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
 #if MGf_COPY
@@ -295,9 +425,14 @@ STATIC SV *vmg_data_get(SV *sv, U16 sig) {
  if (SvTYPE(sv) >= SVt_PVMG) {
   for (mg = SvMAGIC(sv); mg; mg = moremagic) {
    moremagic = mg->mg_moremagic;
-   if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == sig)) { break; }
+   if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
+    MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+    if (w->sig == sig)
+     break;
+   }
   }
-  if (mg) { return mg->mg_obj; }
+  if (mg)
+   return mg->mg_obj;
  }
 
  return NULL;
@@ -332,14 +467,19 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
  if (SvTYPE(sv) >= SVt_PVMG) {
   for (mg = SvMAGIC(sv); mg; mg = moremagic) {
    moremagic = mg->mg_moremagic;
-   if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == w->sig)) { break; }
+   if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
+    MGWIZ *z = SV2MGWIZ(mg->mg_ptr);
+    if (z->sig == w->sig)
+     break;
+   }
   }
-  if (mg) { return 1; }
+  if (mg)
+   return 1;
  }
 
  data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
  mg = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl, (const char *) wiz, HEf_SVKEY);
- mg->mg_private = w->sig;
+ mg->mg_private = SIG_WIZ;
 #if MGf_COPY
  if (w->cb_copy)
   mg->mg_flags |= MGf_COPY;
@@ -380,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. */
@@ -412,28 +553,29 @@ 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;
-  if (mg->mg_type == PERL_MAGIC_ext) {
-   if (mg->mg_private == sig) {
+  if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
+   MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+   if (w->sig == sig) {
 #if VMG_UVAR
     /* If the current has no uvar, short-circuit uvar deletion. */
-    uvars = (SV2MGWIZ(mg->mg_ptr)->uvar) ? (uvars + 1) : 0;
+    uvars = w->uvar ? (uvars + 1) : 0;
 #endif /* VMG_UVAR */
     break;
 #if VMG_UVAR
-   } else if ((mg->mg_private >= SIG_MIN) &&
-              (mg->mg_private <= SIG_MAX) &&
-               SV2MGWIZ(mg->mg_ptr)->uvar) {
+   } else if (w->uvar) {
     ++uvars;
     /* We can't break here since we need to find the ext magic to delete. */
 #endif /* VMG_UVAR */
    }
   }
  }
- if (!mg) { return 0; }
+ if (!mg)
+  return 0;
 
  if (prevmagic) {
   prevmagic->mg_moremagic = moremagic;
@@ -442,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
@@ -451,12 +596,12 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
   /* mg was the first ext magic in the chain that had uvar */
 
   for (mg = moremagic; mg; mg = mg->mg_moremagic) {
-   if ((mg->mg_type == PERL_MAGIC_ext) &&
-       (mg->mg_private >= SIG_MIN) &&
-       (mg->mg_private <= SIG_MAX) &&
-        SV2MGWIZ(mg->mg_ptr)->uvar) {
-    ++uvars;
-    break;
+   if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
+    MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+    if (w->uvar) {
+     ++uvars;
+     break;
+    }
    }
   }
 
@@ -464,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;
@@ -486,44 +632,117 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
  return 1;
 }
 
+/* ... OP info ............................................................. */
+
+#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 };
+
+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;
+   if (!MY_CXT.b__op_stashes[0]) {
+    opclass c;
+    require_pv("B.pm");
+    for (c = 0; c < OPc_MAX; ++c)
+     MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1);
+   }
+   break;
+  }
+  default:
+   break;
+ }
+}
+
+STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
+#define vmg_op_info(W) vmg_op_info(aTHX_ (W))
+ if (!PL_op)
+  return &PL_sv_undef;
+
+ switch (opinfo) {
+  case VMG_OP_INFO_NAME: {
+   OPCODE t = PL_op->op_type;
+   return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t]));
+  }
+  case VMG_OP_INFO_OBJECT: {
+   dMY_CXT;
+   return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))),
+                   MY_CXT.b__op_stashes[vmg_opclass(PL_op)]);
+  }
+  default:
+   break;
+ }
+
+ return &PL_sv_undef;
+}
+
 /* ... svt callbacks ....................................................... */
 
-#define VMG_CB_CALL_ARGS_MASK 15
-#define VMG_CB_CALL_EVAL      16
+#define VMG_CB_CALL_SET_RET(D) \
+ {            \
+  SV *svr;    \
+  SPAGAIN;    \
+  svr = POPs; \
+  ret = SvOK(svr) ? SvIV(svr) : (D); \
+  PUTBACK;    \
+ }
 
-STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
+#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)
+
+STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
  va_list ap;
- SV *svr;
  int ret;
- unsigned int i;
- unsigned int args = flags & VMG_CB_CALL_ARGS_MASK;
- unsigned int eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0;
+ unsigned int i, args, opinfo;
 
  dSP;
 
+ args    = flags & VMG_CB_CALL_ARGS_MASK;
+ flags >>= VMG_CB_CALL_ARGS_SHIFT;
+ opinfo  = flags & VMG_CB_CALL_OPINFO;
+
  ENTER;
  SAVETMPS;
 
  PUSHMARK(SP);
- EXTEND(SP, args + 2);
+ EXTEND(SP, args + 1);
  PUSHs(sv_2mortal(newRV_inc(sv)));
- PUSHs(data ? data : &PL_sv_undef);
- va_start(ap, flags);
+ va_start(ap, sv);
  for (i = 0; i < args; ++i) {
   SV *sva = va_arg(ap, SV *);
   PUSHs(sva ? sva : &PL_sv_undef);
  }
  va_end(ap);
+ if (opinfo)
+  XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
- call_sv(cb, G_SCALAR | eval);
+ call_sv(cb, G_SCALAR);
 
- SPAGAIN;
- if (eval && IN_PERL_COMPILETIME && SvTRUE(ERRSV))
-  ++PL_error_count;
- svr = POPs;
- ret = SvOK(svr) ? SvIV(svr) : 0;
- PUTBACK;
+ VMG_CB_CALL_SET_RET(0);
 
  FREETMPS;
  LEAVE;
@@ -531,21 +750,26 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
  return ret;
 }
 
-#define vmg_cb_call1(I, S, D)         vmg_cb_call(aTHX_ (I), (S), (D), 0)
-#define vmg_cb_call1e(I, S, D)        vmg_cb_call(aTHX_ (I), (S), (D), VMG_CB_CALL_EVAL)
-#define vmg_cb_call2(I, S, D, S2)     vmg_cb_call(aTHX_ (I), (S), (D), 1, (S2))
-#define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call(aTHX_ (I), (S), (D), 2, (S2), (S3))
+#define vmg_cb_call1(I, F, S, A1) \
+        vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 1), (S), (A1))
+#define vmg_cb_call2(I, F, S, A1, A2) \
+        vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 2), (S), (A1), (A2))
+#define vmg_cb_call3(I, F, S, A1, A2, A3) \
+        vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 3), (S), (A1), (A2), (A3))
 
 STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ return vmg_cb_call1(w->cb_get, w->opinfo, sv, mg->mg_obj);
 }
 
 STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ return vmg_cb_call1(w->cb_set, w->opinfo, sv, mg->mg_obj);
 }
 
 STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
- SV *svr;
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ unsigned int opinfo = w->opinfo;
  U32 len, ret;
  svtype t = SvTYPE(sv);
 
@@ -573,14 +797,13 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
   len = 0;
   PUSHs(&PL_sv_undef);
  }
+ if (opinfo)
+  XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
- call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
+ call_sv(w->cb_len, G_SCALAR);
 
- SPAGAIN;
- svr = POPs;
- ret = SvOK(svr) ? SvUV(svr) : len;
- PUTBACK;
+ VMG_CB_CALL_SET_RET(len);
 
  FREETMPS;
  LEAVE;
@@ -589,18 +812,29 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
 }
 
 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ return vmg_cb_call1(w->cb_clear, w->opinfo, sv, mg->mg_obj);
 }
 
 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
- SV *wiz = (SV *) mg->mg_ptr;
+ 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;
 
- /* This may happen in global destruction */
- if (SvTYPE(wiz) == SVTYPEMASK)
+ dSP;
+
+ /* Don't even bother if we are in global destruction - the wizard is prisoner
+  * of circular references and we are way beyond user realm */
+ if (PL_dirty)
   return 0;
 
- /* So that it survives the temp cleanup in vmg_cb_call */
+ w = SV2MGWIZ(mg->mg_ptr);
+
+ /* So that it survives the temp cleanup below */
  SvREFCNT_inc(sv);
 
 #if !VMG_HAS_PERL_MAINT(5, 11, 0, 32686)
@@ -610,7 +844,46 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  SvMAGIC_set(sv, mg);
 #endif
 
- ret = vmg_cb_call1e(SV2MGWIZ(wiz)->cb_free, sv, mg->mg_obj);
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(sv_2mortal(newRV_inc(sv)));
+ PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
+ if (w->opinfo)
+  XPUSHs(vmg_op_info(w->opinfo));
+ PUTBACK;
+
+ had_err = SvTRUE(ERRSV);
+ 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;
+
+ VMG_CB_CALL_SET_RET(0);
+
+ FREETMPS;
+ LEAVE;
 
  /* 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 */
@@ -630,6 +903,7 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
 # endif
  ) {
  SV *keysv;
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
  int ret;
 
  if (keylen == HEf_SVKEY) {
@@ -638,7 +912,7 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
   keysv = newSVpvn(key, keylen);
  }
 
- ret = vmg_cb_call3(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, keysv, nsv);
+ ret = vmg_cb_call3(w->cb_copy, w->opinfo, sv, mg->mg_obj, keysv, nsv);
 
  if (keylen != HEf_SVKEY) {
   SvREFCNT_dec(keysv);
@@ -656,7 +930,8 @@ STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
 
 #if MGf_LOCAL
 STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ return vmg_cb_call1(w->cb_local, w->opinfo, nsv, mg->mg_obj);
 }
 #endif /* MGf_LOCAL */
 
@@ -677,12 +952,14 @@ 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) {
-  MGWIZ *w;
+  const MGWIZ *w;
   switch (mg->mg_type) {
    case PERL_MAGIC_ext:
     break;
@@ -692,8 +969,7 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
    default:
     continue;
   }
-  if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX)
-   continue;
+  if (mg->mg_private != SIG_WIZ) continue;
   w = SV2MGWIZ(mg->mg_ptr);
   switch (w->uvar) {
    case 0:
@@ -704,18 +980,22 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
   }
   switch (action) {
    case 0:
-    if (w->cb_fetch)  { vmg_cb_call2(w->cb_fetch,  sv, mg->mg_obj, key); }
+    if (w->cb_fetch)
+     vmg_cb_call2(w->cb_fetch, w->opinfo, 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,  sv, mg->mg_obj, key); }
+    if (w->cb_store)
+     vmg_cb_call2(w->cb_store, w->opinfo, sv, mg->mg_obj, key);
     break;
    case HV_FETCH_ISEXISTS:
-    if (w->cb_exists) { vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key); }
+    if (w->cb_exists)
+     vmg_cb_call2(w->cb_exists, w->opinfo, sv, mg->mg_obj, key);
     break;
    case HV_DELETE:
-    if (w->cb_delete) { vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key); }
+    if (w->cb_delete)
+     vmg_cb_call2(w->cb_delete, w->opinfo, sv, mg->mg_obj, key);
     break;
   }
  }
@@ -761,32 +1041,40 @@ 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;
- 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);
@@ -812,34 +1100,28 @@ STATIC MGVTBL vmg_wizard_vtbl = {
 #endif /* MGf_LOCAL */
 };
 
-STATIC const char vmg_invalid_wiz[]    = "Invalid wizard object";
-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 U16 vmg_sv2sig(pTHX_ SV *sv) {
 #define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S))
- U16 sig;
+ IV sig;
 
  if (SvIOK(sv)) {
-  sig = SvUVX(sv);
+  sig = SvIVX(sv);
  } else if (SvNOK(sv)) {
   sig = SvNVX(sv);
  } else if ((SvPOK(sv) && grok_number(SvPVX(sv), SvCUR(sv), NULL))) {
-  sig = SvUV(sv);
+  sig = SvIV(sv);
  } else {
   croak(vmg_invalid_sig);
  }
- if (sig < SIG_MIN) { sig += SIG_MIN; }
- if (sig > SIG_MAX) { sig %= SIG_MAX + 1; }
+
+ if (sig < SIG_MIN || sig > SIG_MAX)
+  croak(vmg_invalid_sig);
 
  return sig;
 }
 
 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)) {
@@ -852,16 +1134,17 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  if (!hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))
-   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);
  }
+
  return sig;
 }
 
 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)) {
@@ -879,8 +1162,12 @@ STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  return (old = hv_fetch(MY_CXT, 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;
  }
 }
 
@@ -935,10 +1222,11 @@ STATIC MGWIZ *vmg_wizard_clone(pTHX_ const MGWIZ *w) {
  VMG_CLONE_CB(exists);
  VMG_CLONE_CB(delete);
 #endif /* VMG_UVAR */
- z->owner = aTHX;
- z->vtbl  = t;
- z->sig   = w->sig;
- z->uvar  = w->uvar;
+ z->owner  = aTHX;
+ z->vtbl   = t;
+ z->sig    = w->sig;
+ z->uvar   = w->uvar;
+ z->opinfo = w->opinfo;
 
  return z;
 }
@@ -955,8 +1243,13 @@ 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_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));
@@ -975,6 +1268,9 @@ 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));
 }
 
 #if VMG_THREADSAFE
@@ -984,28 +1280,44 @@ CLONE(...)
 PROTOTYPE: DISABLE
 PREINIT:
  HV *hv;
+ U32 had_b__op_stash = 0;
+ opclass c;
 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;
-   MAGIC *mg;
-   sv = MGWIZ2SV(vmg_wizard_clone(SV2MGWIZ(HeVAL(key))));
-   mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
-   mg->mg_private = SIG_WIZ;
+   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);
-   hv_store(hv, sig, len, sv, HeHASH(key));
+   if (!hv_store(hv, sig, len, sv, HeHASH(key))) croak("%s during CLONE", vmg_globstorefail);
+  }
+  for (c = 0; c < OPc_MAX; ++c) {
+   if (MY_CXT.b__op_stashes[c])
+    had_b__op_stash |= (((U32) 1) << c);
   }
  }
  {
   MY_CXT_CLONE;
-  MY_CXT = hv;
+  MY_CXT.wizards     = hv;
+  for (c = 0; c < OPc_MAX; ++c) {
+   MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c))
+                              ? gv_stashpv(vmg_opclassnames[c], 1) : NULL;
+  }
  }
 
 #endif /* VMG_THREADSAFE */
@@ -1025,7 +1337,7 @@ PREINIT:
 CODE:
  dMY_CXT;
 
- if (items != 7
+ if (items != 8
 #if MGf_COPY
               + 1
 #endif /* MGf_COPY */
@@ -1044,12 +1356,12 @@ CODE:
  if (SvOK(svsig)) {
   SV **old;
   sig = vmg_sv2sig(svsig);
-  if ((old = hv_fetch(MY_CXT, 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);
   }
  } else {
-  if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
   sig = vmg_gensig();
  }
  
@@ -1057,6 +1369,10 @@ CODE:
  Newx(w, 1, MGWIZ);
 
  VMG_SET_CB(ST(i++), data);
+ cb = ST(i++);
+ w->opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ if (w->opinfo)
+  vmg_op_info_init(w->opinfo);
  VMG_SET_SVT_CB(ST(i++), get);
  VMG_SET_SVT_CB(ST(i++), set);
  VMG_SET_SVT_CB(ST(i++), len);
@@ -1093,10 +1409,10 @@ CODE:
 
  sv = MGWIZ2SV(w);
  mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
- mg->mg_private = SIG_WIZ;
+ mg->mg_private = SIG_WZO;
  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:
@@ -1104,18 +1420,24 @@ OUTPUT:
 
 SV *gensig()
 PROTOTYPE:
+PREINIT:
+ U16 sig;
+ char buf[8];
 CODE:
  dMY_CXT;
- if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
- RETVAL = newSVuv(vmg_gensig());
+ 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
 
@@ -1126,8 +1448,6 @@ PREINIT:
  SV *ret;
 CODE:
  wiz = vmg_wizard_wiz(wiz);
- if (!wiz)
-  XSRETURN_UNDEF;
  if (items > 2) {
   I32 i;
   args = newAV();
@@ -1135,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));
@@ -1144,17 +1464,17 @@ CODE:
 OUTPUT:
  RETVAL
 
-SV *getdata(SV *sv, SV *wiz)
+void
+getdata(SV *sv, SV *wiz)
 PROTOTYPE: \[$@%&*]$
 PREINIT:
  SV *data;
  U16 sig;
-CODE:
- sig = vmg_wizard_sig(wiz);
- if (!sig)
-  XSRETURN_UNDEF;
+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);
 
@@ -1164,8 +1484,6 @@ PREINIT:
  U16 sig;
 CODE:
  sig = vmg_wizard_sig(wiz);
- if (!sig)
-  XSRETURN_UNDEF;
  RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig));
 OUTPUT:
  RETVAL