From: Vincent Pit 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/?a=commitdiff_plain;h=c85df5478ff2d9380ee42b0e5a70461d063745d6;p=perl%2Fmodules%2FScope-Upper.git 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; @@ -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; @@ -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 ] } [ [ qw ] ],'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; @@ -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"; + } +}