6 use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5;
8 use Scope::Upper qw<uplevel HERE UP TOP>;
15 my ($depth, $code) = @_;
17 $target = $cxt[$depth];
18 &uplevel($code => $target);
19 pass("$desc: reached end of three()");
25 pass("$desc: reached end of \$two");
31 pass("$desc: reached end of one()");
35 is(HERE, $target, "$desc: right context");
38 my $tester_anon = sub {
39 is(HERE, $target, "$desc: right context");
42 my @subs = (\&three, $two, \&one);
44 for my $height (0 .. 2) {
45 my $base = $subs[$height];
48 my $code = $anon ? $tester_anon : \&tester_sub;
50 for my $depth (0 .. $height) {
52 local $desc = "uplevel at depth $depth/$height";
53 $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
56 eval { $base->($depth, $code) };
57 is $@, '', "$desc: no error";
63 my $desc = 'uplevel called without a code reference';
67 fail "$desc: uplevel should have croaked";
69 like $@, qr/^First argument to uplevel must be a code reference/,"$desc: dies";
75 uplevel { is HERE, $cxt, "$desc: right context" };
76 pass "$desc: reached end of four()";
80 my $desc = 'uplevel called without a target';
85 is $@, '', "$desc: no error";
89 my $desc = 'uplevel to top';
92 uplevel sub { fail "$desc: uplevel body should not be executed" }, TOP;
93 fail "$desc: uplevel should have croaked";
95 like $@, qr/^Can't uplevel outside a subroutine/, "$desc: dies";
99 my $desc = 'uplevel to eval 1';
102 uplevel sub { fail "$desc: uplevel body should not be executed" }, HERE;
103 fail "$desc: uplevel should have croaked";
105 like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
109 my $desc = 'uplevel to eval 2';
114 fail "$desc: uplevel body should not be executed"
116 fail "$desc: uplevel should have croaked";
120 like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
127 sub Scope::Upper::TestCodeDestruction::DESTROY { ++$destroyed }
131 local $destroyed = 0;
132 my $desc = 'target destruction 1';
141 $target = bless $target, 'Scope::Upper::TestCodeDestruction';
147 is $destroyed, 0, "$desc: not yet 1";
149 is $destroyed, 0, "$desc: not yet 2";
153 is $@, '', "$desc: no error";
154 is $destroyed, 0, "$desc: not yet 3";
157 is $destroyed, 1, "$desc: target is detroyed";
161 skip 'This fails even with a plain subroutine call on 5.8.x' => 6
164 local $destroyed = 0;
165 my $desc = 'target destruction 2';
174 $target = bless $target, 'Scope::Upper::TestCodeDestruction';
181 is $destroyed, 0, "$desc: not yet 1";
183 is $destroyed, 0, "$desc: not yet 2";
185 is $destroyed, 0, "$desc: not yet 3";
189 is $@, '', "$desc: no error";
190 is $destroyed, 0, "$desc: not yet 4";
193 is $destroyed, 1, "$desc: target is detroyed";
198 local $destroyed = 0;
199 my $desc = 'target destruction 3';
209 is $destroyed, 0, "$desc: not yet 1";
212 $target = bless $target, 'Scope::Upper::TestCodeDestruction';
217 &uplevel($target => UP);
218 is $destroyed, 0, "$desc: not yet 2";
222 is $@, '', "$desc: no error";
223 is $destroyed, 0, "$desc: not yet 3";
226 is $destroyed, 1, "$desc: target is detroyed";