6 use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7);
8 use Scope::Upper qw<uplevel HERE SUB CALLER>;
13 my @c = caller($depth);
20 is depth(), 0, 'check top depth';
21 is sub { depth() }->(), 1, 'check subroutine call depth';
22 is do { local $@; eval { depth() } }, 1, 'check eval block depth';
25 my $desc = 'exception with no eval in between 1';
29 is depth(), 2, "$desc: correct depth 1";
31 is depth(), 2, "$desc: correct depth 2";
34 fail "$desc: not reached 1";
36 fail "$desc: not reached 2";
38 my $line = __LINE__-6;
39 like $@, qr/^cabbage at \Q$0\E line $line/, "$desc: correct exception";
43 my $desc = 'exception with no eval in between 2';
47 is depth(), 2, "$desc: correct depth 1";
49 is depth(), 2, "$desc: correct depth 2";
51 is depth(), 3, "$desc: correct depth 3";
55 fail "$desc: not reached 1";
57 fail "$desc: not reached 2";
59 my $line = __LINE__-7;
60 like $@, qr/^lettuce at \Q$0\E line $line/, "$desc: correct exception";
64 my $desc = 'exception with no eval in between 3';
68 is depth(), 2, "$desc: correct depth 1";
70 is depth(), 2, "$desc: correct depth 2";
72 is depth(), 3, "$desc: correct depth 3";
76 fail "$desc: not reached 1";
78 fail "$desc: not reached 2";
80 like $@, qr/^onion at \(eval \d+\) line 8/, "$desc: correct exception";
84 my $desc = 'exception with an eval in between 1';
89 is depth(), 3, "$desc: correct depth 1";
91 is depth(), 2, "$desc: correct depth 2";
94 fail "$desc: not reached 1";
96 fail "$desc: not reached 2";
98 fail "$desc: not reached 3";
100 my $line = __LINE__-8;
101 like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
105 my $desc = 'exception with an eval in between 2';
110 is depth(), 3, "$desc: correct depth 1";
112 is depth(), 2, "$desc: correct depth 1";
114 is depth(), 3, "$desc: correct depth 1";
118 fail "$desc: not reached 1";
120 fail "$desc: not reached 2";
122 fail "$desc: not reached 3";
124 my $line = __LINE__-9;
125 like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
129 my $desc = 'exception with an eval in between 3';
134 is depth(), 3, "$desc: correct depth 1";
136 is depth(), 2, "$desc: correct depth 1";
138 is depth(), 3, "$desc: correct depth 1";
142 fail "$desc: not reached 1";
144 fail "$desc: not reached 2";
146 fail "$desc: not reached 3";
148 like $@, qr/^ravioli at \(eval \d+\) line 7/, "$desc: correct exception";
153 skip "Causes failures during global destruction on perl 5.8.[0126]" => 5
154 if ("$]" >= 5.008 and "$]" <= 5.008002) or "$]" == 5.008006;
155 my $desc = 'exception with an eval and a local $@ in between';
156 local $hurp = 'durp';
163 is depth(), 4, "$desc: correct depth 1";
165 is depth(), 2, "$desc: correct depth 2";
168 fail "$desc: not reached 1";
170 fail "$desc: not reached 2";
172 fail "$desc: not reached 3";
174 fail "$desc: not reached 4";
176 my $line = __LINE__-10;
177 like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception";
178 like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset";
179 is $hurp, 'durp', "$desc: force save stack flushing didn't go too far";
183 my $desc = 'several exceptions in a row';
187 is depth(), 2, "$desc (first): correct depth";
189 is depth(), 2, "$desc (first): correct depth";
192 fail "$desc (first): not reached 1";
194 fail "$desc (first): not reached 2";
196 my $line = __LINE__-6;
197 like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
200 is depth(), 2, "$desc (second): correct depth 1";
202 is depth(), 2, "$desc (second): correct depth 2";
205 fail "$desc (second): not reached 1";
207 fail "$desc (second): not reached 2";
210 like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
213 is depth(), 2, "$desc (third): correct depth 1";
215 is depth(), 2, "$desc (third): correct depth 2";
218 fail "$desc (third): not reached 1";
220 fail "$desc (third): not reached 2";
223 like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
226 my $has_B = do { local $@; eval 'require B; 1' };
229 my ($code, $expected, $desc) = @_;
232 skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
234 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
236 my $depth = B::svref_2object($code)->DEPTH;
237 is $depth, $expected, $desc;
242 my ($code, $n, $cxt) = @_;
243 $cxt = SUB unless defined $cxt;
245 bonk($code, $n - 1, $cxt);
247 &uplevel($code, $cxt);
252 my $desc = "an exception unwinding several levels of the same sub 1";
254 check_depth \&bonk, 0, "$desc: depth at the beginning";
259 check_depth \&bonk, $rec + 1, "$desc: depth inside";
264 my $line = __LINE__-4;
265 like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception";
266 check_depth \&bonk, 0, "$desc: depth at the end";
270 my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
271 $m = 0 unless defined $m;
273 clash($pre, $rec, $desc, $cxt, $m + 1, $n);
274 } elsif ($m == $pre) {
275 check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
277 clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
279 my $line = __LINE__+11;
280 like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception";
281 check_depth \&clash, $pre + 1, "$desc: depth after unwinding";
283 $n = 0 unless defined $n;
284 $cxt = SUB unless defined $cxt;
286 clash($pre, $rec, $desc, $cxt, $m, $n + 1);
289 check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
297 my $desc = "an exception unwinding several levels of the same sub 2";
299 check_depth \&clash, 0, "$desc: depth at the beginning";
304 clash($pre, $rec, $desc);
307 is $@, '', "$desc: no exception outside";
308 check_depth \&clash, 0, "$desc: depth at the beginning";