6 use Test::More tests => (13 + 5 + 4) * 2 + 1 + (3 + 3 + 1) + 2 + 4 + 11;
8 use Scope::Upper qw<uplevel HERE UP>;
13 my ($code, $exp_in, $desc) = @_;
15 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
17 my $exp_out = [ 'A', map("X$_", @$exp_in), 'Z' ];
21 @ret_in = &uplevel($code, HERE);
22 is_deeply \@ret_in, $exp_in, "$desc: inside";
26 is_deeply \@ret_out, $exp_out, "$desc: outside";
31 check { return } [ ], 'empty explicit return';
33 check { () } [ ], 'empty implicit return';
35 check { return 1 } [ 1 ], 'one const scalar explicit return';
37 check { 2 } [ 2 ], 'one const scalar implicit return';
41 check { return $x } [ 3 ], 'one lexical scalar explicit return';
46 check { $x } [ 4 ], 'one lexical scalar implicit return';
51 check { return $x } [ 3 ], 'one global scalar explicit return';
56 check { $x } [ 4 ], 'one global scalar implicit return';
59 check { return 1 .. 5 } [ 1 .. 5 ], 'five const scalar explicit return';
61 check { 6 .. 10 } [ 6 .. 10 ], 'five const scalar implicit return';
63 check { 'a' .. 'z' } [ 'a' .. 'z' ], '26 const scalar implicit return';
65 check { [ qw<A B C> ] } [ [ qw<A B C> ] ],'one array reference implicit return';
68 my ($ret) = check { $cb } [ $cb ], 'one anonymous sub implicit return';
69 is $ret->(), $cb->(), 'anonymous sub returned by uplevel still works';
71 for my $run (1 .. 3) {
78 is $cb->(), 124, "near closure returned by uplevel still works";
83 for my $run (1 .. 3) {
90 is $cb->(), 456 + 2 * $run, "far closure returned by uplevel still works";
92 is $id, 456 + 2 * 3, 'captured lexical has the right value at the end';
98 my $desc = 'one scalar explict return between two others, without args';
100 my @ret = (1, uplevel(sub { return 2 }), 3);
101 is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
104 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
108 my $desc = 'one scalar implict return between two others, without args';
110 my @ret = (4, uplevel(sub { 5 }), 6);
111 is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
114 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
118 my $desc = 'one scalar explict return between two others, with args';
120 my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3);
121 is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
124 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
128 my $desc = 'one scalar implict return between two others, with args';
130 my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6);
131 is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
134 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
138 my $desc = 'complex chain of calls';
140 sub one { "<", two("{", @_, "}"), ">" }
141 sub two { "(", three("[", @_, "]"), ")" }
142 sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" }
144 is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside";
149 is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside";
155 skip "goto to an uplevel'd stack frame does not work on perl 5\.6"
156 => 2 if "$]" < 5.008;
159 my $desc = 'values returned from goto';
161 my $cb = sub { 'hello' };
171 is $@, '', "$desc: did not croak";
172 is_deeply \@ret, [ qw<a b c hello x y z> ], "$desc: returned values";
176 # uplevel() to uplevel()
179 my $desc = '\&uplevel as the uplevel() callback';
186 # Note that an XS call does not need a context, so after the first uplevel
187 # call UP will point to the scope above the first target.
188 'a', uplevel(\&uplevel => (sub {
190 } => UP) => UP), 'b';
192 is "@ret", 'a x y z b', "$desc: returned from uplevel";
195 is "@ret", 'u v w', "$desc: returned from the first target";
198 is "@ret", 'm n', "$desc: returned from the second target";
200 is $@, '', "$desc: no error";
206 package Scope::Upper::TestMagic;
209 my ($class, $cb) = @_;
210 bless { cb => $cb }, $class;
213 sub FETCH { $_[0]->{cb}->(@_) }
215 sub STORE { die "Read only magic scalar" }
219 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
220 check { return $mg } [ $$ ], 'one magical scalar explicit return';
221 check { $mg } [ $$ ], 'one magical scalar implicit return';
223 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
224 check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
225 check { $mg2 } [ $$ ], 'one double magical scalar implicit return';
231 package Scope::Upper::TestTimelyDestruction;
234 my ($class, $flag) = @_;
236 bless { flag => $flag }, $class;
248 my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
249 is $destroyed, 0, 'destruction 1: not yet 1';
251 is $destroyed, 0, 'destruction 1: not yet 2';
253 }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
255 is $destroyed, 1, 'destruction 1: destroyed 1';
257 is $destroyed, 1, 'destruction 1: destroyed 2';
261 skip 'This fails even with a plain subroutine call on 5.8.x' => 6
266 my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
267 is $destroyed, 0, 'destruction 2: not yet 1';
269 is $destroyed, 0, 'destruction 2: not yet 2';
271 is $destroyed, 0, 'destruction 2: not yet 3';
273 }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
275 is $destroyed, 0, 'destruction 2: not yet 5';
277 is $destroyed, 1, 'destruction 2: destroyed';