#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
-#include "perl.h"
+#include "perl.h"
#include "XSUB.h"
#define __PACKAGE__ "Scope::Upper"
void *next;
I32 cxix;
+ bool died;
+
CV *target;
+ I32 target_depth;
+
CV *callback;
- bool died;
+ CV *renamed;
+ AV *args;
PERL_SI *si;
PERL_SI *old_curstackinfo;
AV *old_mainstack;
- I32 old_depth;
COP *old_curcop;
bool old_catch;
OP *old_op;
+
+ OP *goto_op;
+ CV *goto_code;
+ U32 goto_perldb;
} su_uplevel_ud;
STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
#endif /* SU_HAS_EXT_MAGIC && !SU_HAS_PERL(5, 13, 7) */
+#define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0]
+
STATIC void su_uplevel_restore(pTHX_ void *sus_) {
su_uplevel_ud *sud = sus_;
- const PERL_CONTEXT *sub_cx;
PERL_SI *cur = sud->old_curstackinfo;
PERL_SI *si = sud->si;
- sub_cx = cxstack + sud->cxix;
+ if (sud->callback) {
+ PERL_CONTEXT *cx = cxstack + sud->cxix;
+ AV *argarray = MUTABLE_AV(su_at_underscore(sud->callback));
+
+ /* We have to fix the pad entry for @_ in the original callback because it
+ * may have been reified. */
+ if (AvREAL(argarray)) {
+ const I32 fill = AvFILLp(argarray);
+ SvREFCNT_dec(argarray);
+ argarray = newAV();
+ AvREAL_off(argarray);
+ AvREIFY_on(argarray);
+ av_extend(argarray, fill);
+ su_at_underscore(sud->callback) = MUTABLE_SV(argarray);
+ } else {
+ CLEAR_ARGARRAY(argarray);
+ }
- /* When we reach this place, POPSUB has already been called (with our fake
- * argarray). GvAV(PL_defgv) points to the savearray (that is, what @_ was
- * before uplevel). argarray is either the fake AV we created in su_uplevel()
- * or some empty replacement POPSUB creates when @_ is reified. In both cases
- * we have to destroy it before the context stack is swapped back to its
- * original state. */
- SvREFCNT_dec(sub_cx->blk_sub.argarray);
+ /* If the old cv member is our renamed CV, it means that this place has been
+ * reached without a goto() happening, and the old argarray member is
+ * actually our fake argarray. Destroy it properly in that case. */
+ if (cx->blk_sub.cv == sud->renamed) {
+ SvREFCNT_dec(cx->blk_sub.argarray);
+ cx->blk_sub.argarray = argarray;
+ }
- /* PUSHSUB was exerted with the original callback, but after calling
- * pp_entersub() we hijacked the blk_sub.cv member of the fresh sub context
- * with the renamed CV. Thus POPSUB and LEAVESUB applied to this CV, not the
- * original. Repair this imbalance right now. */
- if (!(CvDEPTH(sud->callback) = sub_cx->blk_sub.olddepth))
- LEAVESUB(sud->callback);
+ CvDEPTH(sud->callback)--;
+ SvREFCNT_dec(sud->callback);
+ }
- /* Free the renamed cv. */
- {
- CV *renamed_cv = sub_cx->blk_sub.cv;
- CvDEPTH(renamed_cv) = 0;
- SvREFCNT_dec(renamed_cv);
+ /* Free the renamed CV. We must do it ourselves so that we can force the
+ * depth to be 0, or perl would complain about it being "still in use".
+ * But we *know* that it cannot be so. */
+ if (sud->renamed) {
+ CvDEPTH(sud->renamed) = 0;
+ CvPADLIST(sud->renamed) = NULL;
+ SvREFCNT_dec(sud->renamed);
}
CATCH_SET(sud->old_catch);
SU_UPLEVEL_RESTORE(curstackinfo);
if (sud->died) {
- CV *target_cv = sud->target;
+ CV *target = sud->target;
I32 levels = 0, i;
/* When we die, the depth of the target CV is not updated because of the
register const PERL_CONTEXT *cx = cxstack + i;
if (CxTYPE(cx) == CXt_SUB) {
- if (cx->blk_sub.cv == target_cv)
+ if (cx->blk_sub.cv == target)
++levels;
}
}
switch (CxTYPE(cx)) {
case CXt_SUB:
- if (cx->blk_sub.cv == target_cv)
+ if (cx->blk_sub.cv == target)
++levels;
break;
case CXt_EVAL:
}
found_it:
- CvDEPTH(target_cv) = sud->old_depth - levels;
+ CvDEPTH(target) = sud->target_depth - levels;
PL_curstackinfo->si_cxix = i - 1;
#if !SU_HAS_PERL(5, 13, 1)
STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
#define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G))
dVAR;
- AV *protopadlist = CvPADLIST(proto);
- const AV *protopadname = (const AV *) *av_fetch(protopadlist, 0, FALSE);
- SV **pname = AvARRAY(protopadname);
- const I32 fpadlist = AvFILLp(protopadlist);
- const I32 fpadname = AvFILLp(protopadname);
- AV *padlist, *padname;
CV *cv;
cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
CvGV_set(cv, gv);
CvSTASH_set(cv, CvSTASH(proto));
+ /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to
+ * stashes. CvSTASH_set() started to do it as well with commit c68d95645
+ * (which was part of perl 5.13.7). */
+#if SU_HAS_PERL(5, 13, 3) && !SU_HAS_PERL(5, 13, 7)
+ if (CvSTASH(proto))
+ Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv));
+#endif
OP_REFCNT_LOCK;
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
#endif
SvREFCNT_inc_simple_void(CvOUTSIDE(cv));
+ CvPADLIST(cv) = CvPADLIST(proto);
#ifdef CvOUTSIDE_SEQ
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
#endif
if (SvPOK(proto))
sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
- padlist = newAV();
- AvREAL_off(padlist);
- av_fill(padlist, fpadlist);
- CvPADLIST(cv) = padlist;
-
- padname = newAV();
- av_fill(padname, fpadname);
- if (fpadname >= 0) {
- I32 j;
- SV **psvp = AvARRAY(protopadname);
- SV **svp = AvARRAY(padname);
-
- svp[0] = &PL_sv_undef;
- for (j = 1; j <= fpadname; ++j)
- svp[j] = SvREFCNT_inc(psvp[j]);
- }
- AvARRAY(padlist)[0] = MUTABLE_SV(padname);
-
- if (fpadlist >= 1) {
- I32 i;
-
- for (i = 1; i <= fpadlist; ++i) {
- AV *protoframe = MUTABLE_AV(AvARRAY(protopadlist)[i]);
- AV *frame = newAV();
- SV **psvp = AvARRAY(protoframe);
- SV **svp;
- I32 j, fframe = AvFILLp(protoframe);
-
- av_fill(frame, fframe);
- svp = AvARRAY(frame);
- if (i == 1) {
- AV *a0 = newAV(); /* will be @_ */
- AvREAL_off(a0);
- AvREIFY_on(a0);
- svp[0] = MUTABLE_SV(a0);
- } else {
- svp[0] = SvREFCNT_inc(psvp[0]);
- }
- for (j = 1; j <= fframe; ++j)
- svp[j] = SvREFCNT_inc(psvp[j]);
-
- AvARRAY(padlist)[i] = MUTABLE_SV(frame);
- }
- }
-
#ifdef CvCONST
if (CvCONST(cv))
CvCONST_off(cv);
return cv;
}
-STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
+#if SU_HAS_PERL(5, 8, 0)
+
+STATIC int su_uplevel_guard_free(pTHX_ SV *sv, MAGIC *mg) {
+ MAGIC *omg = (MAGIC *) mg->mg_ptr;
+ su_uplevel_ud *sud = (su_uplevel_ud *) omg->mg_ptr;
+ AV *args;
+
+ /* This code should be triggered by the FREETMPS in the first
+ * nextstate/dbstate op of the goto'd code. Its job is to reset the sub
+ * arguments to what the uplevel'd code was called with. */
+
+ if (PL_op != CvSTART(sud->goto_code))
+ croak("su_uplevel_guard_free() was called at an incorrect time");
+ sud->goto_code = NULL;
+
+ /* get_db_sub() has called save_item() on the SV member of the fake GV we
+ * used to replace PL_DBsub, so we can't kill it yet. Since set magic will
+ * be called when the item is restored, we save the fake GV so that we can
+ * correctly drop its refcount just after the restore. */
+ omg->mg_obj = MUTABLE_SV(PL_DBsub);
+ PL_DBsub = NULL;
+
+ args = sud->args;
+ if (args) {
+ PERL_CONTEXT *cx;
+ I32 items = AvFILLp(args);
+ AV *argarray;
+ dSP;
+
+ EXTEND(SP, items + 2);
+ Copy(AvARRAY(args), SP + 1, items + 1, SV *);
+
+ cx = cxstack + cxstack_ix;
+ argarray = cx->blk_sub.argarray;
+ av_extend(argarray, items);
+ Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *);
+ AvFILLp(argarray) = items;
+ }
+
+ return 0;
+}
+
+STATIC MGVTBL su_uplevel_guard_vtbl = {
+ 0,
+ 0,
+ 0,
+ 0,
+ su_uplevel_guard_free
+};
+
+STATIC int su_uplevel_dbsv_get(pTHX_ SV *sv, MAGIC *mg) {
+ su_uplevel_ud *sud = (su_uplevel_ud *) mg->mg_ptr;
+ SV *guard;
+
+ /* This code should be called at the very end of pp_goto, after the
+ * SAVETMPS enclosing the sub was isseud and the blk_sub.cv member is set.
+ * It creates a magical mortal guard that will be destroyed soon at the next
+ * FREETMPS. */
+
+ if (PL_op != sud->goto_op)
+ croak("su_uplevel_dbsv_get() was called at an incorrect time");
+ sud->goto_op = NULL;
+
+ sud->goto_code = cxstack[cxstack_ix].blk_sub.cv;
+ PL_perldb = sud->goto_perldb;
+
+ guard = sv_newmortal();
+ sv_magicext(guard, 0, PERL_MAGIC_ext, &su_uplevel_guard_vtbl,
+ (const char *) mg, 0);
+
+ return 0;
+}
+
+STATIC int su_uplevel_dbsv_set(pTHX_ SV *sv, MAGIC *mg) {
+ su_uplevel_ud *sud = (su_uplevel_ud *) mg->mg_ptr;
+ SV *guard;
+
+ /* This handler is supposed to be executed when the saved GvSV(PL_DBsub)
+ * is restored, which happens when the goto'd code terminates. Its aim is
+ * just to clean up after our hack. */
+
+ if (sud->goto_op)
+ croak("su_uplevel_dbsv_set() called before su_uplevel_dbsv_get");
+ if (sud->goto_code)
+ croak("su_uplevel_dbsv_set() called before su_uplevel_goto_2_free");
+
+ /* Don't free the current magical SV right now, because the mg_*() calls above
+ * us may still need it. */
+ sv_2mortal(sv);
+ SvREFCNT_dec(mg->mg_obj);
+
+ return 0;
+}
+
+STATIC MGVTBL su_uplevel_dbsv_vtbl = {
+ su_uplevel_dbsv_get,
+ su_uplevel_dbsv_set,
+ 0,
+ 0,
+ 0
+};
+
+#ifndef GvSVn
+# ifdef PERL_DONT_CREATE_GVSV
+# define GvSVn(gv) (*(GvGP(gv)->gp_sv ? \
+ &(GvGP(gv)->gp_sv) : \
+ &(GvGP(gv_SVadd(gv))->gp_sv)))
+# else
+# define GvSVn(gv) GvSV(gv)
+# endif
+#endif
+
+STATIC void su_uplevel_goto_handler(pTHX_ void *ud_) {
+ su_uplevel_ud *sud = ud_;
+
+ if (PL_op && PL_op->op_type == OP_GOTO && !PL_DBsub) {
+ SV *dbsv;
+
+ sud->goto_op = PL_op;
+ sud->goto_code = NULL;
+ sud->goto_perldb = PL_perldb;
+
+ PL_DBsub = (GV *) newSV(0);
+ gv_init(PL_DBsub, NULL, "", 0, 0);
+ PL_perldb = PERLDBf_SUB;
+
+ dbsv = GvSVn(PL_DBsub);
+ sv_magicext(dbsv, NULL, PERL_MAGIC_ext, &su_uplevel_dbsv_vtbl,
+ (const char *) sud, 0);
+ SvREFCNT_inc(dbsv);
+ }
+}
+
+#else /* SU_HAS_PERL(5, 8, 0) */
+
+STATIC void su_uplevel_goto_handler(pTHX_ void *ud_) {
+ su_uplevel_ud *sud = ud_;
+
+ if (PL_op && PL_op->op_type == OP_GOTO) {
+ /* Don't let the last sub context in an mixed state while we throw an
+ * exception, as this may cause double free errors (the blk_sub.cv member
+ * is still the renamed CV). Let our su_uplevel_restore() properly handle the
+ * destruction. */
+ cxstack[cxstack_ix].blk_sub.cv = NULL;
+ croak("Can't goto to an uplevel'd stack frame on perl 5.6");
+ }
+}
+
+#endif /* !SU_HAS_PERL(5, 8, 0) */
+
+STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
#define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
su_uplevel_ud *sud;
const PERL_CONTEXT *cx = cxstack + cxix;
PERL_SI *si;
PERL_SI *cur = PL_curstackinfo;
SV **old_stack_sp;
- CV *target_cv;
+ CV *target;
+ CV *renamed;
UNOP sub_op;
I32 gimme;
I32 old_mark, new_mark;
sud->cxix = cxix;
sud->died = 1;
- sud->callback = cv;
+ sud->callback = NULL;
+ sud->renamed = NULL;
+ sud->args = NULL;
SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
si = sud->si;
Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
- target_cv = cx->blk_sub.cv;
- sud->target = (CV *) SvREFCNT_inc(target_cv);
- sud->old_depth = CvDEPTH(target_cv);
+ target = cx->blk_sub.cv;
+ sud->target = (CV *) SvREFCNT_inc(target);
+ sud->target_depth = CvDEPTH(target);
/* blk_oldcop is essentially needed for caller() and stack traces. It has no
* run-time implication, since PL_curcop will be overwritten as soon as we
sud->old_mainstack = NULL;
PL_curstack = si->si_stack;
+ renamed = su_cv_clone(callback, CvGV(target));
+ sud->renamed = renamed;
+
PUSHMARK(SP);
/* Both SP and old_stack_sp point just before the CV. */
Copy(old_stack_sp + 2, SP + 1, args, SV *);
SP += args;
- PUSHs((SV *) cv);
+ PUSHs((SV *) renamed);
PUTBACK;
Zero(&sub_op, 1, UNOP);
CATCH_SET(TRUE);
if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
- PERL_CONTEXT *sub_cx;
- CV *renamed_cv;
-
- renamed_cv = su_cv_clone(cv, CvGV(target_cv));
+ PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
- sub_cx = cxstack + cxstack_ix;
- sub_cx->blk_sub.cv = renamed_cv;
- if (!sub_cx->blk_sub.olddepth) {
- SvREFCNT_inc_simple_void(renamed_cv);
- SvREFCNT_inc_simple_void(renamed_cv);
- SAVEFREESV(renamed_cv);
- }
+ sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
+ CvDEPTH(callback)++;
if (CxHASARGS(cx) && cx->blk_sub.argarray) {
/* The call to pp_entersub() has saved the current @_ (in XS terms,
* argarray with an unreal copy of the original @_. */
AV *av = newAV();
AvREAL_off(av);
+ AvREIFY_on(av);
av_extend(av, AvMAX(cx->blk_sub.argarray));
AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
- cxstack[cxix].blk_sub.argarray = av;
+ sub_cx->blk_sub.argarray = av;
} else {
- SvREFCNT_inc_simple_void(cxstack[cxix].blk_sub.argarray);
+ SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
}
+ sud->args = GvAV(PL_defgv);
+
+ SAVEDESTRUCTOR_X(su_uplevel_goto_handler, sud);
CALLRUNOPS(aTHX);
projects / perl / modules / Scope-Upper.git / blobdiff