From: Vincent Pit <vince@profvince.com>
Date: Tue, 13 Sep 2011 21:10:36 +0000 (+0200)
Subject: Don't rely on being able to access the old context in su_uplevel_restore()
X-Git-Tag: v0.17~10
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=0c640ded3d3d3939e6fb99c3a94c6bf6e54a360a

Don't rely on being able to access the old context in su_uplevel_restore()

It will be overwritten if the callback gotos into another subroutine.
This also fixes "Attempt to free unreferenced scalar" warning when the
debugger is enabled.
---

diff --git a/Upper.xs b/Upper.xs
index 2ad1a46..fadbe3d 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -201,6 +201,10 @@ typedef struct {
  I32  target_depth;
 
  CV  *callback;
+ I32  callback_depth;
+ CV  *renamed;
+
+ AV *fake_argarray;
 
  PERL_SI *si;
  PERL_SI *old_curstackinfo;
@@ -1011,32 +1015,28 @@ 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(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);
@@ -1282,9 +1282,11 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
 
  sud = su_uplevel_storage_new();
 
- sud->cxix     = cxix;
- sud->died     = 1;
- sud->callback = callback;
+ 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;
@@ -1362,17 +1364,19 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
  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(callback, CvGV(target));
+  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) {
@@ -1386,10 +1390,11 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
    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);
 
diff --git a/t/60-uplevel-target.t b/t/60-uplevel-target.t
index 246af7b..1dcf325 100644
--- a/t/60-uplevel-target.t
+++ b/t/60-uplevel-target.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6;
+use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6 + 5;
 
 use Scope::Upper qw<uplevel HERE UP TOP>;
 
@@ -253,4 +253,32 @@ sub four {
 
   is $destroyed, 0,  "$desc: code is destroyed";
  }
+
+ SKIP: {
+  skip 'This fails even with a plain subroutine call on 5.8.x' => 5
+                                                                if "$]" < 5.009;
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'code destruction and goto';
+
+  {
+   my $lexical = 0;
+   my $cb = sub {
+    ++$lexical;
+    is $destroyed, 0, "$desc: not yet 1";
+   };
+   $cb = bless $cb, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    sub {
+     &uplevel(sub { goto $cb } => HERE);
+     is $destroyed, 0, "$desc: not yet 2";
+    }->();
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  }
+
+  is $destroyed, 1, "$desc: code is destroyed";
+ }
 }