]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/13-reap-ctl.t
Rename some variables and struct members around su_uplevel()
[perl/modules/Scope-Upper.git] / t / 13-reap-ctl.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 41 + 30 + 4 * 7;
7
8 use Scope::Upper qw<reap UP HERE>;
9
10 our ($x, $y);
11
12 sub check { ++$y }
13
14 {
15  local $x = 1;
16  {
17   local $x = 2;
18   {
19    reap \&check => UP;
20   }
21   is $x, 2,     'goto 1 [not yet - x]';
22   is $y, undef, 'goto 1 [not yet - y]';
23   {
24    local $x = 3;
25    goto OVER1;
26   }
27  }
28  $y = 0;
29 OVER1:
30  is $x, 1, 'goto 1 [ok - x]';
31  is $y, 1, 'goto 1 [ok - y]';
32 }
33
34 $y = undef;
35 {
36  local $x = 1;
37  {
38   local $x = 2;
39   {
40    local $x = 3;
41    {
42     reap \&check => UP UP;
43    }
44    is $x, 3,     'goto 2 [not yet - x]';
45    is $y, undef, 'goto 2 [not yet - y]';
46    {
47     local $x = 4;
48     goto OVER2;
49    }
50   }
51  }
52  $y = 0;
53 OVER2:
54  is $x, 1, 'goto 2 [ok - x]';
55  is $y, 1, 'goto 2 [ok - y]';
56 }
57
58 $y = undef;
59 {
60  local $x = 1;
61  {
62   eval {
63    local $x = 2;
64    {
65     {
66      local $x = 3;
67      reap \&check => UP UP UP;
68      is $x, 3,     'die - reap outside eval [not yet 1 - x]';
69      is $y, undef, 'die - reap outside eval [not yet 1 - y]';
70     }
71     is $x, 2,     'die - reap outside eval [not yet 2 - x]';
72     is $y, undef, 'die - reap outside eval [not yet 2 - y]';
73     die;
74    }
75   };
76   is $x, 1,     'die - reap outside eval [not yet 3 - x]';
77   is $y, undef, 'die - reap outside eval [not yet 3 - y]';
78  } # should trigger here
79  is $x, 1, 'die - reap outside eval [ok - x]';
80  is $y, 1, 'die - reap outside eval [ok - y]';
81 }
82
83 $y = undef;
84 {
85  local $x = 1;
86  eval {
87   local $x = 2;
88   {
89    {
90     local $x = 3;
91     reap \&check => UP UP;
92     is $x, 3,     'die - reap at eval [not yet 1 - x]';
93     is $y, undef, 'die - reap at eval [not yet 1 - y]';
94    }
95    is $x, 2,     'die - reap at eval [not yet 2 - x]';
96    is $y, undef, 'die - reap at eval [not yet 2 - y]';
97    die;
98   }
99  }; # should trigger here
100  is $x, 1, 'die - reap at eval [ok - x]';
101  is $y, 1, 'die - reap at eval [ok - y]';
102 }
103
104 $y = undef;
105 {
106  local $x = 1;
107  eval {
108   local $x = 2;
109   {
110    {
111     local $x = 3;
112     reap \&check => UP;
113     is $x, 3,     'die - reap inside eval [not yet 1 - x]';
114     is $y, undef, 'die - reap inside eval [not yet 1 - y]';
115    }
116    is $x, 2,     'die - reap inside eval [not yet 2 - x]';
117    is $y, undef, 'die - reap inside eval [not yet 2 - y]';
118    die;
119   } # should trigger here
120  };
121  is $x, 1, 'die - reap inside eval [ok - x]';
122  is $y, 1, 'die - reap inside eval [ok - y]';
123 }
124
125 {
126  my $z      = 0;
127  my $reaped = 0;
128  eval {
129   reap { $reaped = 1 };
130   is $reaped, 0, 'died of natural death - not reaped yet';
131   my $res = 1 / $z;
132  };
133  my $err = $@;
134  is   $reaped, 1,                    'died of natural death - reaped';
135  like $err,    qr/division by zero/, 'died of natural death - divided by zero';
136 }
137
138 SKIP:
139 {
140  skip 'Perl 5.10 required to test given/when' => 30 if "$]" < 5.010;
141
142  eval <<' GIVEN_TEST_1';
143   use feature 'switch';
144   local $y;
145   {
146    local $x = 1;
147    given (1) {
148     local $x = 2;
149     when (1) {
150      local $x = 3;
151      reap \&check => UP;
152      is $x, 3,     'given/when - reap at given [not yet - x]';
153      is $y, undef, 'given/when - reap at given [not yet - y]';
154     }
155     fail 'not reached';
156    }
157    is $x, 1, 'given/when - reap at given [ok - x]';
158    is $y, 1, 'given/when - reap at given [ok - y]';
159   }
160  GIVEN_TEST_1
161  fail $@ if $@;
162
163  eval <<' GIVEN_TEST_2';
164   use feature 'switch';
165   local $y;
166   {
167    local $x = 1;
168    given (1) {
169     local $x = 2;
170     when (1) {
171      local $x = 3;
172      reap \&check => UP;
173      is $x, 3,     'given/when/continue - reap at given [not yet 1 - x]';
174      is $y, undef, 'given/when/continue - reap at given [not yet 1 - y]';
175      continue;
176     }
177     is $x, 2,     'given/when/continue - reap at given [not yet 2 - x]';
178     is $y, undef, 'given/when/continue - reap at given [not yet 2 - y]';
179    }
180    is $x, 1, 'given/when/continue - reap at given [ok - x]';
181    is $y, 1, 'given/when/continue - reap at given [ok - y]';
182   }
183  GIVEN_TEST_2
184  fail $@ if $@;
185
186  eval <<' GIVEN_TEST_3';
187   use feature 'switch';
188   local $y;
189   {
190    local $x = 1;
191    given (1) {
192     local $x = 2;
193     default {
194      local $x = 3;
195      reap \&check => UP;
196      is $x, 3,     'given/default - reap at given [not yet - x]';
197      is $y, undef, 'given/default - reap at given [not yet - y]';
198     }
199     fail 'not reached';
200    }
201    is $x, 1, 'given/default - reap at given [ok - x]';
202    is $y, 1, 'given/default - reap at given [ok - y]';
203   }
204  GIVEN_TEST_3
205  fail $@ if $@;
206
207  eval <<' GIVEN_TEST_4';
208   use feature 'switch';
209   local $y;
210   {
211    local $x = 1;
212    given (1) {
213     local $x = 2;
214     default {
215      local $x = 3;
216      reap \&check => UP;
217      is $x, 3,     'given/default/continue - reap at given [not yet 1 - x]';
218      is $y, undef, 'given/default/continue - reap at given [not yet 1 - y]';
219      continue;
220     }
221     is $x, 2,     'given/default/continue - reap at given [not yet 2 - x]';
222     is $y, undef, 'given/default/continue - reap at given [not yet 2 - y]';
223    }
224    is $x, 1, 'given/default/continue - reap at given [ok - x]';
225    is $y, 1, 'given/default/continue - reap at given [ok - y]';
226   }
227  GIVEN_TEST_4
228  fail $@ if $@;
229
230  eval <<' GIVEN_TEST_5';
231   use feature 'switch';
232   local $y;
233   {
234    local $x = 1;
235    given (1) {
236     local $x = 2;
237     default {
238      local $x = 3;
239      given (2) {
240       local $x = 4;
241       when (2) {
242        local $x = 5;
243        reap \&check => UP UP;
244        is $x, 5,     'given/default/given/when - reap at default [not yet 1 - x]';
245        is $y, undef, 'given/default/given/when - reap at default [not yet 1 - y]';
246        continue;
247       }
248       is $x, 4,     'given/default/given/when - reap at default [not yet 2 - x]';
249       is $y, undef, 'given/default/given/when - reap at default [not yet 2 - y]';
250      }
251      is $x, 3,     'given/default/given/when - reap at default [not yet 3 - x]';
252      is $y, undef, 'given/default/given/when - reap at default [not yet 3 - y]';
253      continue;
254     }
255     is $x, 2, 'given/default/given/when - reap at default [ok 1 - x]';
256     is $y, 1, 'given/default/given/when - reap at default [ok 1 - y]';
257    }
258    is $x, 1, 'given/default/given/when - reap at default [ok 2 - x]';
259    is $y, 1, 'given/default/given/when - reap at default [ok 2 - y]';
260   }
261  GIVEN_TEST_5
262  fail $@ if $@;
263 }
264
265 $y = undef;
266 {
267  local $x = 1;
268  eval {
269   local $x = 2;
270   eval {
271    local $x = 3;
272    reap { ++$y; die "reaped\n" } => HERE;
273    is $x, 3,     'die in reap at eval [not yet - x]';
274    is $y, undef, 'die in reap at eval [not yet - y]';
275   }; # should trigger here, but the die isn't catched by this eval
276   die "failed\n";
277  };
278  is $@, "reaped\n", 'die in reap at eval [ok - $@]';
279  is $x, 1, 'die in reap at eval [ok - x]';
280  is $y, 1, 'die in reap at eval [ok - y]';
281 }
282
283 $y = undef;
284 {
285  local $x = 1;
286  eval {
287   local $x = 2;
288   {
289    local $x = 3;
290    reap { ++$y; die "reaped\n" } => HERE;
291    is $x, 3,     'die in reap inside eval [not yet - x]';
292    is $y, undef, 'die in reap inside eval [not yet - y]';
293   } # should trigger here
294   die "failed\n";
295  };
296  is $@, "reaped\n", 'die in reap inside eval [ok - $@]';
297  is $x, 1, 'die in reap inside eval [ok - x]';
298  is $y, 1, 'die in reap inside eval [ok - y]';
299 }
300
301 sub hijacked {
302  my ($cb, $desc) = @_;
303  local $x = 2;
304  sub {
305   local $x = 3;
306   &reap($cb => UP);
307   is $x, 3,     "$desc [not yet 1 - x]";
308   is $y, undef, "$desc [not yet 1 - y]";
309  }->();
310  is $x, 2,     "$desc [not yet 2 - x]";
311  is $y, undef, "$desc [not yet 2 - y]";
312  11, 12;
313 }
314
315 for ([ sub { ++$y; 15, 16, 17, 18 },        'implicit ' ],
316      [ sub { ++$y; return 15, 16, 17, 18 }, ''          ]) {
317  my ($cb, $imp) = @$_;
318  $imp = "RT #44204 - ${imp}return from reap";
319  my $desc;
320  $y = undef;
321  {
322   $desc = "$imp in list context";
323   local $x = 1;
324   my @l = hijacked($cb, $desc);
325   is $x,         1,          "$desc [ok - x]";
326   is $y,         1,          "$desc [ok - y]";
327   is_deeply \@l, [ 11, 12 ], "$desc [ok - l]";
328  }
329  $y = undef;
330  {
331   $desc = "$imp in list context";
332   local $x = 1;
333   my $s = hijacked($cb, $desc);
334   is $x, 1,  "$desc [ok - x]";
335   is $y, 1,  "$desc [ok - y]";
336   is $s, 12, "$desc [ok - s]";
337  }
338 }