X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=blobdiff_plain;f=Magic.xs;h=c199f7eb2e5847a3e411c4c9b32fe73f3a46073a;hp=15164cc8adf8be638062352676565131b5433c47;hb=bd7cdd0635d30485b50564b9eebb2d73b3c0f94b;hpb=4622b2e2dd6a1ee85bbc63dfb5c736be78d87beb

diff --git a/Magic.xs b/Magic.xs
index 15164cc..c199f7e 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -139,6 +139,12 @@
 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
 #endif
 
+#if VMG_HAS_PERL(5, 17, 4)
+# define VMG_COMPAT_SCALAR_NOLEN 1
+#else
+# define VMG_COMPAT_SCALAR_NOLEN 0
+#endif
+
 /* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160, partially
  * reverted to dev-5.11 as 9cdcb38b */
 #if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0)
@@ -187,6 +193,11 @@
 # define VMG_COMPAT_GLOB_GET 0
 #endif
 
+#define VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE (VMG_HAS_PERL(5, 10, 0) && !VMG_HAS_PERL(5, 10, 1))
+
+/* NewOp() isn't public in perl 5.8.0. */
+#define VMG_RESET_RMG_NEEDS_TRAMPOLINE (VMG_UVAR && (VMG_THREADSAFE || !VMG_HAS_PERL(5, 8, 1)))
+
 /* ... Bug-free mg_magical ................................................. */
 
 /* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */
@@ -220,11 +231,50 @@ STATIC void vmg_mg_magical(SV *sv) {
 
 #endif
 
-/* ... Safe version of call_sv() ........................................... */
+/* --- Trampoline ops ------------------------------------------------------ */
+
+#define VMG_NEEDS_TRAMPOLINE VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE || VMG_RESET_RMG_NEEDS_TRAMPOLINE
+
+#if VMG_NEEDS_TRAMPOLINE
+
+typedef struct {
+ OP   temp;
+ SVOP target;
+} vmg_trampoline;
+
+STATIC void vmg_trampoline_init(vmg_trampoline *t, OP *(*cb)(pTHX)) {
+ t->temp.op_type    = OP_STUB;
+ t->temp.op_ppaddr  = 0;
+ t->temp.op_next    = (OP *) &t->target;
+ t->temp.op_flags   = 0;
+ t->temp.op_private = 0;
+
+ t->target.op_type    = OP_STUB;
+ t->target.op_ppaddr  = cb;
+ t->target.op_next    = NULL;
+ t->target.op_flags   = 0;
+ t->target.op_private = 0;
+ t->target.op_sv      = NULL;
+}
+
+STATIC OP *vmg_trampoline_bump(pTHX_ vmg_trampoline *t, SV *sv, OP *o) {
+#define vmg_trampoline_bump(T, S, O) vmg_trampoline_bump(aTHX_ (T), (S), (O))
+ t->temp         = *o;
+ t->temp.op_next = (OP *) &t->target;
+
+ t->target.op_sv   = sv;
+ t->target.op_next = o->op_next;
+
+ return &t->temp;
+}
+
+#endif /* VMG_NEEDS_TRAMPOLINE */
+
+/* --- Safe version of call_sv() ------------------------------------------- */
 
 STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), void *ud) {
 #define vmg_call_sv(S, F, C, U) vmg_call_sv(aTHX_ (S), (F), (C), (U))
- I32 ret, cxix, in_eval = 0;
+ I32 ret, cxix;
  PERL_CONTEXT saved_cx;
  SV *old_err = NULL;
 
@@ -233,12 +283,7 @@ STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), vo
   ERRSV   = newSV(0);
  }
 
- if (cxstack_ix < cxstack_max) {
-  cxix    = cxstack_ix + 1;
-  in_eval = CxTYPE(cxstack + cxix) == CXt_EVAL;
- } else {
-  cxix    = Perl_cxinc(aTHX);
- }
+ cxix     = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
  /* The last popped context will be reused by call_sv(), but our callers may
   * still need its previous value. Back it up so that it isn't clobbered. */
  saved_cx = cxstack[cxix];
@@ -269,7 +314,7 @@ STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), vo
 #else
    ++PL_Ierror_count;
 #endif
-  } else if (!in_eval) {
+  } else {
    if (!cleanup || cleanup(aTHX_ ud))
     croak(NULL);
   }
@@ -401,9 +446,15 @@ 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];
- I32    depth;
- MAGIC *freed_tokens;
+ HV             *b__op_stashes[OPc_MAX];
+ I32             depth;
+ MAGIC          *freed_tokens;
+#if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
+ vmg_trampoline  propagate_errsv;
+#endif
+#if VMG_RESET_RMG_NEEDS_TRAMPOLINE
+ vmg_trampoline  reset_rmg;
+#endif
 } my_cxt_t;
 
 START_MY_CXT
@@ -1304,26 +1355,116 @@ STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
 
 /* ... free magic .......................................................... */
 
-STATIC int vmg_svt_free_cleanup(pTHX_ void *ud) {
- SV    *sv = VOID2(SV *, ud);
- MAGIC *mg;
+#if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
 
- /* We are about to croak() while sv is being destroyed. Try to clean up
-  * things a bit. */
- mg = SvMAGIC(sv);
- if (mg) {
-  vmg_mg_del(sv, NULL, mg, mg->mg_moremagic);
-  mg_magical(sv);
+STATIC OP *vmg_pp_propagate_errsv(pTHX) {
+ SVOP *o = cSVOPx(PL_op);
+
+ if (o->op_sv) {
+  SvREFCNT_dec(ERRSV);
+  ERRSV    = o->op_sv;
+  o->op_sv = NULL;
  }
- SvREFCNT_dec(sv);
 
- vmg_dispell_guard_oncroak(aTHX_ ud);
+ return NORMAL;
+}
 
- /* After that, propagate the error upwards. */
- return 1;
+#endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
+
+STATIC int vmg_propagate_errsv_free(pTHX_ SV *sv, MAGIC *mg) {
+ if (mg->mg_obj) {
+  ERRSV         = mg->mg_obj;
+  mg->mg_obj    = NULL;
+  mg->mg_flags &= ~MGf_REFCOUNTED;
+ }
+
+ return 0;
+}
+
+/* perl is already kind enough to handle the cloning of the mg_obj member,
+   hence we don't need to define a dup magic callback. */
+
+STATIC MGVTBL vmg_propagate_errsv_vtbl = {
+ 0,                        /* get */
+ 0,                        /* set */
+ 0,                        /* len */
+ 0,                        /* clear */
+ vmg_propagate_errsv_free, /* free */
+ 0,                        /* copy */
+ 0,                        /* dup */
+#if MGf_LOCAL
+ 0,                        /* local */
+#endif /* MGf_LOCAL */
+};
+
+typedef struct {
+ SV  *sv;
+ int  in_eval;
+ I32  base;
+} vmg_svt_free_cleanup_ud;
+
+STATIC int vmg_svt_free_cleanup(pTHX_ void *ud_) {
+ vmg_svt_free_cleanup_ud *ud = VOID2(vmg_svt_free_cleanup_ud *, ud_);
+
+ if (ud->in_eval) {
+  U32 optype = PL_op ? PL_op->op_type : OP_NULL;
+
+  if (optype == OP_LEAVETRY || optype == OP_LEAVEEVAL) {
+   SV *errsv = newSVsv(ERRSV);
+
+   FREETMPS;
+   LEAVE_SCOPE(ud->base);
+
+#if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
+   if (optype == OP_LEAVETRY) {
+    dMY_CXT;
+    PL_op = vmg_trampoline_bump(&MY_CXT.propagate_errsv, errsv, PL_op);
+   } else if (optype == OP_LEAVEEVAL) {
+    SV *guard = sv_newmortal();
+    sv_magicext(guard, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl,
+                              NULL, 0);
+   }
+#else /* !VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
+# if !VMG_HAS_PERL(5, 8, 9)
+   {
+    SV *guard = sv_newmortal();
+    sv_magicext(guard, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl,
+                              NULL, 0);
+   }
+# else
+   sv_magicext(ERRSV, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl,
+                             NULL, 0);
+   SvREFCNT_dec(errsv);
+# endif
+#endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
+
+   SAVETMPS;
+  }
+
+  /* Don't propagate */
+  return 0;
+ } else {
+  SV    *sv = ud->sv;
+  MAGIC *mg;
+
+  /* We are about to croak() while sv is being destroyed. Try to clean up
+   * things a bit. */
+  mg = SvMAGIC(sv);
+  if (mg) {
+   vmg_mg_del(sv, NULL, mg, mg->mg_moremagic);
+   mg_magical(sv);
+  }
+  SvREFCNT_dec(sv);
+
+  vmg_dispell_guard_oncroak(aTHX_ NULL);
+
+  /* After that, propagate the error upwards. */
+  return 1;
+ }
 }
 
 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
+ vmg_svt_free_cleanup_ud ud;
  const vmg_wizard *w;
  int ret = 0;
  SV *svr;
@@ -1347,6 +1488,15 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  SvMAGIC_set(sv, mg);
 #endif
 
+ ud.sv = sv;
+ if (cxstack_ix < cxstack_max) {
+  ud.in_eval = (CxTYPE(cxstack + cxstack_ix + 1) == CXt_EVAL);
+  ud.base    = ud.in_eval ? PL_scopestack[PL_scopestack_ix] : 0;
+ } else {
+  ud.in_eval = 0;
+  ud.base    = 0;
+ }
+
  ENTER;
  SAVETMPS;
 
@@ -1361,7 +1511,7 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  {
   dMY_CXT;
   MY_CXT.depth++;
-  vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, sv);
+  vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, &ud);
   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).
@@ -1450,8 +1600,12 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
 
 #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;
 }
 
@@ -1532,17 +1686,35 @@ 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;
+
+#if VMG_RESET_RMG_NEEDS_TRAMPOLINE
+
+  dMY_CXT;
+
+  PL_op = vmg_trampoline_bump(&MY_CXT.reset_rmg, sv, PL_op);
+
+#else /* !VMG_RESET_RMG_NEEDS_TRAMPOLINE */
+
+  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;
+
+#endif /* VMG_RESET_RMG_NEEDS_TRAMPOLINE */
+
   SvRMAGICAL_off(sv);
  }
 
@@ -1608,8 +1780,19 @@ 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;
+
+ /* XS doesn't like a blank line here */
+#if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
+ vmg_trampoline_init(&MY_CXT.propagate_errsv, vmg_pp_propagate_errsv);
+#endif
+#if VMG_RESET_RMG_NEEDS_TRAMPOLINE
+ vmg_trampoline_init(&MY_CXT.reset_rmg, vmg_pp_reset_rmg);
+#endif
+
+ /* XS doesn't like a blank line here */
 #if VMG_THREADSAFE
  MUTEX_INIT(&vmg_vtable_refcount_mutex);
  MUTEX_INIT(&vmg_op_name_init_mutex);
@@ -1622,6 +1805,8 @@ BOOT:
  newCONSTSUB(stash, "VMG_UVAR",  newSVuv(VMG_UVAR));
  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
+ newCONSTSUB(stash, "VMG_COMPAT_SCALAR_NOLEN",
+                    newSVuv(VMG_COMPAT_SCALAR_NOLEN));
  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN",
                     newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID",