6 use Test::More tests => (10 + 5 + 4) * 2 + 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' ];
20 my @ret = &uplevel($code, HERE);
21 is_deeply \@ret, $exp_in, "$desc: inside";
25 is_deeply \@ret, $exp_out, "$desc: outside";
28 check { return } [ ], 'empty explicit return';
30 check { () } [ ], 'empty implicit return';
32 check { return 1 } [ 1 ], 'one const scalar explicit return';
34 check { 2 } [ 2 ], 'one const scalar implicit return';
38 check { return $x } [ 3 ], 'one lexical scalar explicit return';
43 check { $x } [ 4 ], 'one lexical scalar implicit return';
48 check { return $x } [ 3 ], 'one global scalar explicit return';
53 check { $x } [ 4 ], 'one global scalar implicit return';
56 check { return 1 .. 5 } [ 1 .. 5 ], 'five const scalar explicit return';
58 check { 6 .. 10 } [ 6 .. 10 ], 'five const scalar implicit return';
63 my $desc = 'one scalar explict return between two others, without args';
65 my @ret = (1, uplevel(sub { return 2 }), 3);
66 is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
69 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
73 my $desc = 'one scalar implict return between two others, without args';
75 my @ret = (4, uplevel(sub { 5 }), 6);
76 is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
79 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
83 my $desc = 'one scalar explict return between two others, with args';
85 my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3);
86 is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
89 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
93 my $desc = 'one scalar implict return between two others, with args';
95 my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6);
96 is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
99 is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
103 my $desc = 'complex chain of calls';
105 sub one { "<", two("{", @_, "}"), ">" }
106 sub two { "(", three("[", @_, "]"), ")" }
107 sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" }
109 is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside";
114 is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside";
120 package Scope::Upper::TestMagic;
123 my ($class, $cb) = @_;
124 bless { cb => $cb }, $class;
127 sub FETCH { $_[0]->{cb}->(@_) }
129 sub STORE { die "Read only magic scalar" }
133 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
134 check { return $mg } [ $$ ], 'one magical scalar explicit return';
135 check { $mg } [ $$ ], 'one magical scalar implicit return';
137 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
138 check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
139 check { $mg2 } [ $$ ], 'one double magical scalar implicit return';
145 package Scope::Upper::TestTimelyDestruction;
148 my ($class, $flag) = @_;
150 bless { flag => $flag }, $class;
162 my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
163 is $destroyed, 0, 'destruction 1: not yet 1';
165 is $destroyed, 0, 'destruction 1: not yet 2';
167 }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
169 is $destroyed, 1, 'destruction 1: destroyed 1';
171 is $destroyed, 1, 'destruction 1: destroyed 2';
175 skip 'This fails even with a plain subroutine call on 5.8.x' => 6
180 my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
181 is $destroyed, 0, 'destruction 2: not yet 1';
183 is $destroyed, 0, 'destruction 2: not yet 2';
185 is $destroyed, 0, 'destruction 2: not yet 3';
187 }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
189 is $destroyed, 0, 'destruction 2: not yet 5';
191 is $destroyed, 1, 'destruction 2: destroyed';