Activate the correct pad when calling the uplevel'd code

[perl/modules/Scope-Upper.git] / Upper.xs

diff --git a/Upper.xs b/Upper.xs
index dfc4169acc8195025f9dce5e650dbef996ba9eb5..44103d029aa0912174d3cd27f9d3e347fe338350 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -163,6 +163,7 @@ typedef struct {
 
  I32  cxix;
  CV  *target;
+ CV  *callback;
  bool died;
 
  PERL_SI *si;
@@ -174,7 +175,6 @@ typedef struct {
 
  bool old_catch;
  OP  *old_op;
- CV  *cloned_cv;
 } su_uplevel_ud;
 
 STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
@@ -976,20 +976,35 @@ STATIC MGVTBL su_uplevel_restore_vtbl = {
 
 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(cxstack[sud->cxix].blk_sub.argarray);
+ SvREFCNT_dec(sub_cx->blk_sub.argarray);
 
- CATCH_SET(sud->old_catch);
+ /* 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);
 
- SvREFCNT_dec(sud->cloned_cv);
+ /* Free the renamed cv. */
+ {
+  CV *renamed_cv = sub_cx->blk_sub.cv;
+  CvDEPTH(renamed_cv) = 0;
+  SvREFCNT_dec(renamed_cv);
+ }
+
+ CATCH_SET(sud->old_catch);
 
  SU_UPLEVEL_RESTORE(op);
 
@@ -1185,15 +1200,20 @@ STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
  SPAGAIN;
 
  sud = su_uplevel_storage_new();
- si  = sud->si;
 
- sud->cxix = cxix;
- sud->died = 1;
+ sud->cxix     = cxix;
+ sud->died     = 1;
+ sud->callback = cv;
  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
 
- si->si_type = cur->si_type;
- si->si_next = NULL;
- si->si_prev = cur->si_prev;
+ si = sud->si;
+
+ si->si_type    = cur->si_type;
+ si->si_next    = NULL;
+ si->si_prev    = cur->si_prev;
+#ifdef DEBUGGING
+ si->si_markoff = cx->blk_oldmarksp;
+#endif
 
  /* Allocate enough space for all the elements of the original stack up to the
   * target context, plus the forthcoming arguments. */
@@ -1210,10 +1230,6 @@ STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
  PL_stack_max  = PL_stack_base + AvMAX(si->si_stack);
  SPAGAIN;
 
-#ifdef DEBUGGING
- si->si_markoff = cx->blk_oldmarksp;
-#endif
-
  /* Copy the context stack up to the context just below the target. */
  si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
  if (si->si_cxmax < cxix) {
@@ -1245,10 +1261,6 @@ STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
   sud->old_mainstack = NULL;
  PL_curstack = si->si_stack;
 
- cv = su_cv_clone(cv);
- sud->cloned_cv = cv;
- CvGV_set(cv, CvGV(target_cv));
-
  PUSHMARK(SP);
  /* Both SP and old_stack_sp point just before the CV. */
  Copy(old_stack_sp + 2, SP + 1, args, SV *);
@@ -1269,6 +1281,21 @@ STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
  CATCH_SET(TRUE);
 
  if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
+  PERL_CONTEXT *sub_cx;
+  CV *renamed_cv;
+
+  renamed_cv = su_cv_clone(cv);
+  CvDEPTH(renamed_cv) = CvDEPTH(cv);
+  CvGV_set(renamed_cv, CvGV(target_cv));
+
+  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);
+  }
+
   if (CxHASARGS(cx) && cx->blk_sub.argarray) {
    /* The call to pp_entersub() has saved the current @_ (in XS terms,
     * GvAV(PL_defgv)) in the savearray member, and has created a new argarray