6 use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7) + 1;
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 my $loc = $^P ? "[$0:" . (__LINE__-14) . ']' : '';
81 like $@, qr/^onion at \(eval \d+\)\Q$loc\E line 8/, "$desc: correct exception";
85 my $desc = 'exception with an eval in between 1';
90 is depth(), 3, "$desc: correct depth 1";
92 is depth(), 2, "$desc: correct depth 2";
95 fail "$desc: not reached 1";
97 fail "$desc: not reached 2";
99 fail "$desc: not reached 3";
101 my $line = __LINE__-8;
102 like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
106 my $desc = 'exception with an eval in between 2';
111 is depth(), 3, "$desc: correct depth 1";
113 is depth(), 2, "$desc: correct depth 1";
115 is depth(), 3, "$desc: correct depth 1";
119 fail "$desc: not reached 1";
121 fail "$desc: not reached 2";
123 fail "$desc: not reached 3";
125 my $line = __LINE__-9;
126 like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
130 my $desc = 'exception with an eval in between 3';
135 is depth(), 3, "$desc: correct depth 1";
137 is depth(), 2, "$desc: correct depth 1";
139 is depth(), 3, "$desc: correct depth 1";
143 fail "$desc: not reached 1";
145 fail "$desc: not reached 2";
147 fail "$desc: not reached 3";
149 my $loc = $^P ? "[$0:" . (__LINE__-15) . ']' : '';
150 like $@, qr/^ravioli at \(eval \d+\)\Q$loc\E line 7/,
151 "$desc: correct exception";
156 skip "Causes failures during global destruction on perl 5.8.[0-6]" => 5
157 if "$]" >= 5.008 and "$]" <= 5.008_006;
158 my $desc = 'exception with an eval and a local $@ in between';
159 local $hurp = 'durp';
166 is depth(), 4, "$desc: correct depth 1";
168 is depth(), 2, "$desc: correct depth 2";
171 fail "$desc: not reached 1";
173 fail "$desc: not reached 2";
175 fail "$desc: not reached 3";
177 fail "$desc: not reached 4";
179 my $line = __LINE__-10;
180 like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception";
181 like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset";
182 is $hurp, 'durp', "$desc: force save stack flushing didn't go too far";
186 my $desc = 'several exceptions in a row';
190 is depth(), 2, "$desc (first): correct depth";
192 is depth(), 2, "$desc (first): correct depth";
195 fail "$desc (first): not reached 1";
197 fail "$desc (first): not reached 2";
199 my $line = __LINE__-6;
200 like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
203 is depth(), 2, "$desc (second): correct depth 1";
205 is depth(), 2, "$desc (second): correct depth 2";
208 fail "$desc (second): not reached 1";
210 fail "$desc (second): not reached 2";
213 like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
216 is depth(), 2, "$desc (third): correct depth 1";
218 is depth(), 2, "$desc (third): correct depth 2";
221 fail "$desc (third): not reached 1";
223 fail "$desc (third): not reached 2";
226 like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
229 my $has_B = do { local $@; eval { require B; 1 } };
232 my ($code, $expected, $desc) = @_;
235 skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
237 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
239 my $depth = B::svref_2object($code)->DEPTH;
240 is $depth, $expected, $desc;
245 my ($code, $n, $cxt) = @_;
246 $cxt = SUB unless defined $cxt;
248 bonk($code, $n - 1, $cxt);
250 &uplevel($code, $cxt);
255 my $desc = "an exception unwinding several levels of the same sub 1";
257 check_depth \&bonk, 0, "$desc: depth at the beginning";
262 check_depth \&bonk, $rec + 1, "$desc: depth inside";
267 my $line = __LINE__-4;
268 like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception";
269 check_depth \&bonk, 0, "$desc: depth at the end";
273 my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
274 $m = 0 unless defined $m;
276 clash($pre, $rec, $desc, $cxt, $m + 1, $n);
277 } elsif ($m == $pre) {
278 check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
280 clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
282 my $line = __LINE__+11;
283 like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception";
284 check_depth \&clash, $pre + 1, "$desc: depth after unwinding";
286 $n = 0 unless defined $n;
287 $cxt = SUB unless defined $cxt;
289 clash($pre, $rec, $desc, $cxt, $m, $n + 1);
292 check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
300 my $desc = "an exception unwinding several levels of the same sub 2";
302 check_depth \&clash, 0, "$desc: depth at the beginning";
307 clash($pre, $rec, $desc);
310 is $@, '', "$desc: no exception outside";
311 check_depth \&clash, 0, "$desc: depth at the beginning";
317 my $desc = 'exception thrown from XS';
321 &uplevel(\&uplevel => \1, HERE);
324 my $line = $^P ? '\d+' : __LINE__-2; # The error happens at the target frame.
325 my $file = $^P ? '\S+' : quotemeta $0;
327 qr/^First argument to uplevel must be a code reference at $file line $line/,
328 "$desc: correct error";