summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
inline | side by side (from parent 1:
361c028)
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.
bool old_catch;
OP *old_op;
bool old_catch;
OP *old_op;
} su_uplevel_ud;
STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
} su_uplevel_ud;
STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
STATIC void su_uplevel_restore(pTHX_ void *sus_) {
su_uplevel_ud *sud = sus_;
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;
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. */
/* 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);
sud = su_uplevel_storage_new();
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;
SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
si = sud->si;
sud->old_mainstack = NULL;
PL_curstack = si->si_stack;
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 *);
PUSHMARK(SP);
/* Both SP and old_stack_sp point just before the CV. */
Copy(old_stack_sp + 2, SP + 1, args, SV *);
CATCH_SET(TRUE);
if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
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
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
use strict;
use warnings;
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>;
use Scope::Upper qw<uplevel HERE UP TOP>;
is $destroyed, 1, "$desc: target is detroyed";
}
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";
+ }
use strict;
use warnings;
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>;
use Scope::Upper qw<uplevel HERE UP>;
my $exp_out = [ 'A', map("X$_", @$exp_in), 'Z' ];
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";
- is_deeply \@ret, $exp_out, "$desc: outside";
+ is_deeply \@ret_out, $exp_out, "$desc: outside";
+
+ @ret_in;
}
check { return } [ ], 'empty explicit return';
}
check { return } [ ], 'empty explicit return';
check { 6 .. 10 } [ 6 .. 10 ], 'five const scalar implicit 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";
+}
+
use strict;
use warnings;
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More tests => 4 + 3 * 2;
use Scope::Upper qw<uplevel HERE UP>;
use Scope::Upper qw<uplevel HERE UP>;
uplevel { is $1, 'x', 'match variables scoping 2' } UP;
}->();
}->();
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";
+ }
+}