From: Vincent Pit <vince@profvince.com>
Date: Fri, 9 Sep 2011 23:53:13 +0000 (+0200)
Subject: Activate the correct pad when calling the uplevel'd code
X-Git-Tag: rt71212~1
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=c85df5478ff2d9380ee42b0e5a70461d063745d6

Activate the correct pad when calling the uplevel'd code

This fixes at least two issues :
- closures defined inside the uplevel callback can now wrap around
lexicals from inside (but not outside yet, this will be fixed by the
next commit).
- state variables in the uplevel callback now work properly.
---

diff --git a/Upper.xs b/Upper.xs
index aee877f..44103d0 100644
--- 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);
 
@@ -1186,8 +1201,9 @@ STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
 
  sud = su_uplevel_storage_new();
 
- sud->cxix = cxix;
- sud->died = 1;
+ sud->cxix     = cxix;
+ sud->died     = 1;
+ sud->callback = cv;
  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
 
  si = sud->si;
@@ -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
diff --git a/t/60-uplevel-target.t b/t/60-uplevel-target.t
index 6b3a444..246af7b 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;
+use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6;
 
 use Scope::Upper qw<uplevel HERE UP TOP>;
 
@@ -225,4 +225,32 @@ sub four {
 
   is $destroyed, 1, "$desc: target is detroyed";
  }
+
+ {
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'code destruction';
+
+  {
+   my $lexical;
+   my $code = sub {
+    ++$lexical;
+    is $destroyed, 0, "$desc: not yet 1";
+   };
+
+   eval {
+    sub {
+     sub {
+      &uplevel($code, UP);
+      is $destroyed, 0, "$desc: not yet 2";
+     }->();
+     is $destroyed, 0, "$desc: not yet 2";
+    }->();
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  };
+
+  is $destroyed, 0,  "$desc: code is destroyed";
+ }
 }
diff --git a/t/62-uplevel-return.t b/t/62-uplevel-return.t
index 76c922f..ccf763b 100644
--- a/t/62-uplevel-return.t
+++ b/t/62-uplevel-return.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => (10 + 5 + 4) * 2 + 11;
+use Test::More tests => (13 + 5 + 4) * 2 + 1 + 3 + 11;
 
 use Scope::Upper qw<uplevel HERE UP>;
 
@@ -16,13 +16,16 @@ sub check (&$$) {
 
  my $exp_out = [ 'A', map("X$_", @$exp_in), 'Z' ];
 
- my @ret = sub {
-  my @ret = &uplevel($code, HERE);
-  is_deeply \@ret, $exp_in, "$desc: inside";
+ my @ret_in;
+ my @ret_out = sub {
+  @ret_in = &uplevel($code, HERE);
+  is_deeply \@ret_in, $exp_in, "$desc: inside";
   @$exp_out;
  }->('dummy');
 
- is_deeply \@ret, $exp_out, "$desc: outside";
+ is_deeply \@ret_out, $exp_out, "$desc: outside";
+
+ @ret_in;
 }
 
 check { return } [ ], 'empty explicit return';
@@ -57,6 +60,24 @@ check { return 1 .. 5 } [ 1 .. 5 ],  'five const scalar explicit return';
 
 check { 6 .. 10 }       [ 6 .. 10 ], 'five const scalar implicit return';
 
+check { 'a' .. 'z' }    [ 'a' .. 'z' ], '26 const scalar implicit return';
+
+check { [ qw<A B C> ] } [ [ qw<A B C> ] ],'one array reference implicit return';
+
+my $cb = sub { 123 };
+my ($ret) = check { $cb } [ $cb ], 'one anonymous sub implicit return';
+is $ret->(), $cb->(), 'anonymous sub returned by uplevel still works';
+
+for my $run (1 .. 3) {
+ my ($cb) = sub {
+  uplevel {
+   my $id = 123;
+   sub { ++$id };
+  };
+ }->('dummy');
+ is $cb->(), 124, "near closure returned by uplevel still works";
+}
+
 # Mark
 
 {
diff --git a/t/67-uplevel-scope.t b/t/67-uplevel-scope.t
index 715c50c..92105fc 100644
--- a/t/67-uplevel-scope.t
+++ b/t/67-uplevel-scope.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 4;
+use Test::More tests => 4 + 3 * 2;
 
 use Scope::Upper qw<uplevel HERE UP>;
 
@@ -44,3 +44,30 @@ sub {
   uplevel { is $1, 'x', 'match variables scoping 2' } UP;
  }->();
 }->();
+
+SKIP: {
+ skip 'No state variables before perl 5.10' => 3 * 2 unless "$]" >= 5.010;
+
+ my $desc = 'state variables';
+
+ {
+  local $@;
+  eval 'use feature "state"; sub herp { state $id = 123; return ++$id }';
+  die $@ if $@;
+ }
+
+ sub derp {
+  sub {
+   &uplevel(\&herp => UP);
+  }->();
+ }
+
+ for my $run (1 .. 3) {
+  local $@;
+  my $ret = eval {
+   derp()
+  };
+  is $@,   '',         "$desc: run $run did not croak";
+  is $ret, 123 + $run, "$desc: run $run returned the correct value";
+ }
+}