void *next;
I32 cxix;
+ bool died;
+
CV *target;
+ I32 target_depth;
+
CV *callback;
- bool died;
+ I32 callback_depth;
+ CV *renamed;
+
+ AV *fake_argarray;
PERL_SI *si;
PERL_SI *old_curstackinfo;
AV *old_mainstack;
- I32 old_depth;
COP *old_curcop;
bool old_catch;
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;
-
/* 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);
+ SvREFCNT_dec(sud->fake_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))
+ if (!(CvDEPTH(sud->callback) = sud->callback_depth))
LEAVESUB(sud->callback);
/* Free the renamed cv. */
- {
- CV *renamed_cv = sub_cx->blk_sub.cv;
- CvDEPTH(renamed_cv) = 0;
- SvREFCNT_dec(renamed_cv);
+ if (sud->renamed) {
+ CvDEPTH(sud->renamed) = 0;
+ 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)
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));
return cv;
}
-STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
+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;
UNOP sub_op;
I32 gimme;
I32 old_mark, new_mark;
sud = su_uplevel_storage_new();
- sud->cxix = cxix;
- sud->died = 1;
- sud->callback = cv;
+ sud->cxix = cxix;
+ sud->died = 1;
+ sud->callback = callback;
+ sud->renamed = NULL;
+ sud->fake_argarray = 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
/* 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 *) callback);
PUTBACK;
Zero(&sub_op, 1, UNOP);
CATCH_SET(TRUE);
if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
- PERL_CONTEXT *sub_cx;
- CV *renamed_cv;
+ PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
+ CV *renamed;
+
+ sud->callback_depth = sub_cx->blk_sub.olddepth;
- renamed_cv = su_cv_clone(cv, CvGV(target_cv));
+ renamed = su_cv_clone(callback, CvGV(target));
+ sud->renamed = renamed;
- sub_cx = cxstack + cxstack_ix;
- sub_cx->blk_sub.cv = renamed_cv;
+ sub_cx->blk_sub.cv = renamed;
if (!sub_cx->blk_sub.olddepth) {
- SvREFCNT_inc_simple_void(renamed_cv);
- SvREFCNT_inc_simple_void(renamed_cv);
- SAVEFREESV(renamed_cv);
+ SvREFCNT_inc_simple_void(renamed);
+ SvREFCNT_inc_simple_void(renamed);
+ SAVEFREESV(renamed);
}
if (CxHASARGS(cx) && cx->blk_sub.argarray) {
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->fake_argarray = sub_cx->blk_sub.argarray;
CALLRUNOPS(aTHX);
projects / perl / modules / Scope-Upper.git / blobdiff