# 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)
# 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 */
#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;
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];
#else
++PL_Ierror_count;
#endif
- } else if (!in_eval) {
+ } else {
if (!cleanup || cleanup(aTHX_ ud))
croak(NULL);
}
#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
/* ... 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;
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;
{
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).
* 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. */
+
+#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;
svop->op_sv = sv;
+#endif /* VMG_RESET_RMG_NEEDS_TRAMPOLINE */
+
SvRMAGICAL_off(sv);
}
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);
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",
projects / perl / modules / Variable-Magic.git / blobdiff