]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/63-uplevel-ctl.t
645d6f89439b2ccf4f943ab28d93675f6d581243
[perl/modules/Scope-Upper.git] / t / 63-uplevel-ctl.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7);
7
8 use Scope::Upper qw<uplevel HERE SUB CALLER>;
9
10 sub depth {
11  my $depth = 0;
12  while (1) {
13   my @c = caller($depth);
14   last unless @c;
15   ++$depth;
16  }
17  return $depth - 1;
18 }
19
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';
23
24 {
25  my $desc = 'exception with no eval in between 1';
26  local $@;
27  eval {
28   sub {
29    is depth(), 2, "$desc: correct depth 1";
30    uplevel {
31     is depth(), 2, "$desc: correct depth 2";
32     die 'cabbage';
33    };
34    fail "$desc: not reached 1";
35   }->();
36   fail "$desc: not reached 2";
37  };
38  my $line = __LINE__-6;
39  like $@, qr/^cabbage at \Q$0\E line $line/, "$desc: correct exception";
40 }
41
42 {
43  my $desc = 'exception with no eval in between 2';
44  local $@;
45  eval {
46   sub {
47    is depth(), 2, "$desc: correct depth 1";
48    uplevel {
49     is depth(), 2, "$desc: correct depth 2";
50     sub {
51      is depth(), 3, "$desc: correct depth 3";
52      die 'lettuce';
53     }->();
54    };
55    fail "$desc: not reached 1";
56   }->();
57   fail "$desc: not reached 2";
58  };
59  my $line = __LINE__-7;
60  like $@, qr/^lettuce at \Q$0\E line $line/, "$desc: correct exception";
61 }
62
63 {
64  my $desc = 'exception with no eval in between 3';
65  local $@;
66  eval q[
67   sub {
68    is depth(), 2, "$desc: correct depth 1";
69    uplevel {
70     is depth(), 2, "$desc: correct depth 2";
71     sub {
72      is depth(), 3, "$desc: correct depth 3";
73      die 'onion';
74     }->();
75    };
76    fail "$desc: not reached 1";
77   }->();
78   fail "$desc: not reached 2";
79  ];
80  like $@, qr/^onion at \(eval \d+\) line 8/, "$desc: correct exception";
81 }
82
83 {
84  my $desc = 'exception with an eval in between 1';
85  local $@;
86  eval {
87   sub {
88    eval {
89     is depth(), 3, "$desc: correct depth 1";
90     uplevel {
91      is depth(), 2, "$desc: correct depth 2";
92      die 'macaroni';
93     } SUB;
94     fail "$desc: not reached 1";
95    };
96    fail "$desc: not reached 2";
97   }->();
98   fail "$desc: not reached 3";
99  };
100  my $line = __LINE__-8;
101  like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
102 }
103
104 {
105  my $desc = 'exception with an eval in between 2';
106  local $@;
107  eval {
108   sub {
109    eval {
110     is depth(), 3, "$desc: correct depth 1";
111     uplevel {
112      is depth(), 2, "$desc: correct depth 1";
113      sub {
114       is depth(), 3, "$desc: correct depth 1";
115       die 'spaghetti';
116      }->();
117     } SUB;
118     fail "$desc: not reached 1";
119    };
120    fail "$desc: not reached 2";
121   }->();
122   fail "$desc: not reached 3";
123  };
124  my $line = __LINE__-9;
125  like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
126 }
127
128 {
129  my $desc = 'exception with an eval in between 3';
130  local $@;
131  eval {
132   sub {
133    eval q[
134     is depth(), 3, "$desc: correct depth 1";
135     uplevel {
136      is depth(), 2, "$desc: correct depth 1";
137      sub {
138       is depth(), 3, "$desc: correct depth 1";
139       die 'ravioli';
140      }->();
141     } SUB;
142     fail "$desc: not reached 1";
143     ];
144    fail "$desc: not reached 2";
145   }->();
146   fail "$desc: not reached 3";
147  };
148  like $@, qr/^ravioli at \(eval \d+\) line 7/, "$desc: correct exception";
149 }
150 our $hurp;
151
152 SKIP: {
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';
157  local $@;
158  my $x = (eval {
159   sub {
160    local $@;
161    eval {
162     sub {
163      is depth(), 4, "$desc: correct depth 1";
164      uplevel {
165       is depth(), 2, "$desc: correct depth 2";
166       die 'lasagna'
167      } CALLER(2);
168      fail "$desc: not reached 1";
169     }->();
170     fail "$desc: not reached 2";
171    };
172    fail "$desc: not reached 3";
173   }->();
174   fail "$desc: not reached 4";
175  }, $@);
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";
180 }
181
182 {
183  my $desc = 'several exceptions in a row';
184  local $@;
185  eval {
186   sub {
187    is depth(), 2, "$desc (first): correct depth";
188    uplevel {
189     is depth(), 2, "$desc (first): correct depth";
190     die 'carrot';
191    };
192    fail "$desc (first): not reached 1";
193   }->();
194   fail "$desc (first): not reached 2";
195  };
196  my $line = __LINE__-6;
197  like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
198  eval {
199   sub {
200    is depth(), 2, "$desc (second): correct depth 1";
201    uplevel {
202     is depth(), 2, "$desc (second): correct depth 2";
203     die 'potato';
204    };
205    fail "$desc (second): not reached 1";
206   }->();
207   fail "$desc (second): not reached 2";
208  };
209  $line = __LINE__-6;
210  like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
211  eval {
212   sub {
213    is depth(), 2, "$desc (third): correct depth 1";
214    uplevel {
215     is depth(), 2, "$desc (third): correct depth 2";
216     die 'tomato';
217    };
218    fail "$desc (third): not reached 1";
219   }->();
220   fail "$desc (third): not reached 2";
221  };
222  $line = __LINE__-6;
223  like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
224 }
225
226 my $has_B = do { local $@; eval 'require B; 1' };
227
228 sub check_depth {
229  my ($code, $expected, $desc) = @_;
230
231  SKIP: {
232   skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
233
234   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
235
236   my $depth = B::svref_2object($code)->DEPTH;
237   is $depth, $expected, $desc;
238  }
239 }
240
241 sub bonk {
242  my ($code, $n, $cxt) = @_;
243  $cxt = SUB unless defined $cxt;
244  if ($n) {
245   bonk($code, $n - 1, $cxt);
246  } else {
247   &uplevel($code, $cxt);
248  }
249 }
250
251 {
252  my $desc = "an exception unwinding several levels of the same sub 1";
253  local $@;
254  check_depth \&bonk, 0, "$desc: depth at the beginning";
255  my $rec = 7;
256  sub {
257   eval {
258    bonk(sub {
259     check_depth \&bonk, $rec + 1, "$desc: depth inside";
260     die 'pepperoni';
261    }, $rec);
262   }
263  }->();
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";
267 }
268
269 sub clash {
270  my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
271  $m = 0 unless defined $m;
272  if ($m < $pre) {
273   clash($pre, $rec, $desc, $cxt, $m + 1, $n);
274  } elsif ($m == $pre) {
275   check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
276   eval {
277    clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
278   };
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";
282  } else {
283   $n   = 0   unless defined $n;
284   $cxt = SUB unless defined $cxt;
285   if ($n < $rec) {
286    clash($pre, $rec, $desc, $cxt, $m, $n + 1);
287   } else {
288    uplevel {
289     check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
290     die 'garlic';
291    } $cxt;
292   }
293  }
294 }
295
296 {
297  my $desc = "an exception unwinding several levels of the same sub 2";
298  local $@;
299  check_depth \&clash, 0, "$desc: depth at the beginning";
300  my $pre = 5;
301  my $rec = 10;
302  sub {
303   eval {
304    clash($pre, $rec, $desc);
305   }
306  }->();
307  is $@, '', "$desc: no exception outside";
308  check_depth \&clash, 0, "$desc: depth at the beginning";
309 }