]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/60-uplevel-target.t
Make sure the code snippets fit in 80-columns wide terminal
[perl/modules/Scope-Upper.git] / t / 60-uplevel-target.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More
7              tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 7 + (5 + 6 + 5 + 6 + 5);
8
9 use Scope::Upper qw<uplevel HERE UP TOP>;
10
11 our ($desc, $target);
12
13 my @cxt;
14
15 sub three {
16  my ($depth, $code) = @_;
17  $cxt[0] = HERE;
18  $target = $cxt[$depth];
19  &uplevel($code => $target);
20  pass("$desc: reached end of three()");
21 }
22
23 my $two = sub {
24  $cxt[1] = HERE;
25  three(@_);
26  pass("$desc: reached end of \$two");
27 };
28
29 sub one {
30  $cxt[2] = HERE;
31  $two->(@_);
32  pass("$desc: reached end of one()");
33 }
34
35 sub tester_sub {
36  is(HERE, $target, "$desc: right context");
37 }
38
39 my $tester_anon = sub {
40  is(HERE, $target, "$desc: right context");
41 };
42
43 my @subs = (\&three, $two, \&one);
44
45 for my $height (0 .. 2) {
46  my $base = $subs[$height];
47
48  for my $anon (0, 1) {
49   my $code = $anon ? $tester_anon : \&tester_sub;
50
51   for my $depth (0 .. $height) {
52    local $target;
53    local $desc = "uplevel at depth $depth/$height";
54    $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
55
56    local $@;
57    eval { $base->($depth, $code) };
58    is $@, '', "$desc: no error";
59   }
60  }
61 }
62
63 {
64  my $desc = 'uplevel called without a code reference';
65  local $@;
66  eval {
67   three(0, "wut");
68   fail "$desc: uplevel should have croaked";
69  };
70  like $@, qr/^First argument to uplevel must be a code reference/,"$desc: dies";
71 }
72
73 sub four {
74  my $desc = shift;
75  my $cxt  = HERE;
76  uplevel { is HERE, $cxt, "$desc: right context" };
77  pass "$desc: reached end of four()";
78 }
79
80 {
81  my $desc = 'uplevel called without a target';
82  local $@;
83  eval {
84   four($desc);
85  };
86  is $@, '', "$desc: no error";
87 }
88
89 {
90  my $desc = 'uplevel to top';
91  local $@;
92  eval {
93   uplevel sub { fail "$desc: uplevel body should not be executed" }, TOP;
94   fail "$desc: uplevel should have croaked";
95  };
96  like $@, qr/^Can't uplevel outside a subroutine/, "$desc: dies";
97 }
98
99 {
100  my $desc = 'uplevel to eval 1';
101  local $@;
102  eval {
103   uplevel sub { fail "$desc: uplevel body should not be executed" }, HERE;
104   fail "$desc: uplevel should have croaked";
105  };
106  like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
107 }
108
109 {
110  my $desc = 'uplevel to eval 2';
111  local $@;
112  sub {
113   eval {
114    uplevel {
115     fail "$desc: uplevel body should not be executed"
116    };
117    fail "$desc: uplevel should have croaked";
118   };
119   return;
120  }->();
121  like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
122 }
123
124 # XS
125
126 {
127  my $desc = 'uplevel to XS 1';
128  local $@;
129  eval {
130   sub {
131    my $cxt = HERE;
132    pass "$desc: before";
133    &uplevel(\&HERE => $cxt);
134    is HERE, $cxt, "$desc: after";
135   }->();
136  };
137  is $@, '', "$desc: no error";
138 }
139
140 {
141  my $desc = 'uplevel to XS 1';
142  local $@;
143  eval {
144   sub {
145    my $up = HERE;
146    sub {
147     is UP, $up, "$desc: before";
148     &uplevel(\&HERE => $up);
149     isnt HERE, $up, "$desc: after 1";
150    }->();
151    is HERE, $up, "$desc: after 2";
152   }->();
153  };
154  is $@, '', "$desc: no error";
155 }
156
157 # Target destruction
158
159 {
160  our $destroyed;
161  sub Scope::Upper::TestCodeDestruction::DESTROY { ++$destroyed }
162
163  {
164   local $@;
165   local $destroyed = 0;
166   my $desc = 'target destruction 1';
167
168   {
169    my $lexical;
170    my $target = sub {
171     my $code = shift;
172     ++$lexical;
173     $code->();
174    };
175    $target = bless $target, 'Scope::Upper::TestCodeDestruction';
176
177    eval {
178     $target->(
179      sub {
180       uplevel {
181        is $destroyed, 0, "$desc: not yet 1";
182       } UP;
183       is $destroyed, 0, "$desc: not yet 2";
184      },
185     );
186    };
187    is $@,         '', "$desc: no error";
188    is $destroyed, 0,  "$desc: not yet 3";
189   }
190
191   is $destroyed, 1, "$desc: target is detroyed";
192  }
193
194  SKIP: {
195   skip 'This fails even with a plain subroutine call on 5.8.x' => 6
196                                                                 if "$]" < 5.009;
197   local $@;
198   local $destroyed = 0;
199   my $desc = 'target destruction 2';
200
201   {
202    my $lexical;
203    my $target = sub {
204     my $code = shift;
205     ++$lexical;
206     $code->();
207    };
208    $target = bless $target, 'Scope::Upper::TestCodeDestruction';
209
210    eval {
211     $target->(
212      sub {
213       uplevel {
214        $target->(sub {
215         is $destroyed, 0, "$desc: not yet 1";
216        });
217        is $destroyed, 0, "$desc: not yet 2";
218       } UP;
219       is $destroyed, 0, "$desc: not yet 3";
220      },
221     );
222    };
223    is $@,         '', "$desc: no error";
224    is $destroyed, 0,  "$desc: not yet 4";
225   }
226
227   is $destroyed, 1, "$desc: target is detroyed";
228  }
229
230  {
231   local $@;
232   local $destroyed = 0;
233   my $desc = 'target destruction 3';
234
235   {
236    my $lexical;
237    my $target = sub {
238     ++$lexical;
239     if (@_) {
240      my $code = shift;
241      $code->();
242     } else {
243      is $destroyed, 0, "$desc: not yet 1";
244     }
245    };
246    $target = bless $target, 'Scope::Upper::TestCodeDestruction';
247
248    eval {
249     $target->(
250      sub {
251       &uplevel($target => UP);
252       is $destroyed, 0, "$desc: not yet 2";
253      },
254     );
255    };
256    is $@,         '', "$desc: no error";
257    is $destroyed, 0,  "$desc: not yet 3";
258   }
259
260   is $destroyed, 1, "$desc: target is detroyed";
261  }
262
263  SKIP: {
264   skip 'This fails even with a plain subroutine call on 5.8.x' => 6
265                                                                 if "$]" < 5.009;
266   local $@;
267   local $destroyed = 0;
268   my $desc = 'code destruction';
269
270   {
271    my $lexical;
272    my $code = sub {
273     ++$lexical;
274     is $destroyed, 0, "$desc: not yet 1";
275    };
276    $code = bless $code, 'Scope::Upper::TestCodeDestruction';
277
278    eval {
279     sub {
280      sub {
281       &uplevel($code, UP);
282       is $destroyed, 0, "$desc: not yet 2";
283      }->();
284      is $destroyed, 0, "$desc: not yet 2";
285     }->();
286    };
287    is $@,         '', "$desc: no error";
288    is $destroyed, 0,  "$desc: not yet 3";
289   };
290
291   is $destroyed, 1, "$desc: code is destroyed";
292  }
293
294  SKIP: {
295   skip 'This fails even with a plain subroutine call on 5.8.x' => 5
296                                                                 if "$]" < 5.009;
297   local $@;
298   local $destroyed = 0;
299   my $desc = 'code destruction and goto';
300
301   {
302    my $lexical = 0;
303    my $cb = sub {
304     ++$lexical;
305     is $destroyed, 0, "$desc: not yet 1";
306    };
307    $cb = bless $cb, 'Scope::Upper::TestCodeDestruction';
308
309    eval {
310     sub {
311      &uplevel(sub { goto $cb } => HERE);
312      is $destroyed, 0, "$desc: not yet 2";
313     }->();
314    };
315    is $@,         '', "$desc: no error";
316    is $destroyed, 0,  "$desc: not yet 3";
317   }
318
319   is $destroyed, 1, "$desc: code is destroyed";
320  }
321 }