1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7}
8
9plan 29;
10
11use feature 'defer';
12no warnings 'experimental::defer';
13
14{
15    my $x = "";
16    {
17        defer { $x = "a" }
18    }
19    is($x, "a", 'defer block is invoked');
20
21    {
22        defer {
23            $x = "";
24            $x .= "abc";
25            $x .= "123";
26        }
27    }
28    is($x, "abc123", 'defer block can contain multiple statements');
29
30    {
31       defer {}
32    }
33    ok(1, 'Empty defer block parses OK');
34}
35
36{
37    my $x = "";
38    {
39        defer { $x .= "a" }
40        defer { $x .= "b" }
41        defer { $x .= "c" }
42    }
43    is($x, "cba", 'defer blocks happen in LIFO order');
44}
45
46{
47    my $x = "";
48
49    {
50        defer { $x .= "a" }
51        $x .= "A";
52    }
53
54    is($x, "Aa", 'defer blocks happen after the main body');
55}
56
57{
58    my $x = "";
59
60    foreach my $i (qw( a b c )) {
61        defer { $x .= $i }
62    }
63
64    is($x, "abc", 'defer block happens for every iteration of foreach');
65}
66
67{
68    my $x = "";
69
70    my $cond = 0;
71    if( $cond ) {
72        defer { $x .= "XXX" }
73    }
74
75    is($x, "", 'defer block does not happen inside non-taken conditional branch');
76}
77
78{
79    my $x = "";
80
81    while(1) {
82        last;
83        defer { $x .= "a" }
84    }
85
86    is($x, "", 'defer block does not happen if entered but unencountered');
87}
88
89{
90   my $x = "";
91
92   my $counter = 1;
93   {
94      defer { $x .= "A" }
95      redo if $counter++ < 5;
96   }
97
98   is($x, "AAAAA", 'defer block can happen multiple times');
99}
100
101{
102    my $x = "";
103
104    {
105        defer {
106            $x .= "a";
107            defer {
108                $x .= "b";
109            }
110        }
111    }
112
113    is($x, "ab", 'defer block can contain another defer');
114}
115
116{
117    my $x = "";
118    my $value = do {
119        defer { $x .= "before" }
120        "value";
121    };
122
123    is($x, "before", 'defer blocks run inside do { }');
124    is($value, "value", 'defer block does not disturb do { } value');
125}
126
127{
128    my $x = "";
129    my $sub = sub {
130        defer { $x .= "a" }
131    };
132
133    $sub->();
134    $sub->();
135    $sub->();
136
137    is($x, "aaa", 'defer block inside sub');
138}
139
140{
141    my $x = "";
142    my $sub = sub {
143        return;
144        defer { $x .= "a" }
145    };
146
147    $sub->();
148
149    is($x, "", 'defer block inside sub does not happen if entered but returned early');
150}
151
152{
153   my $x = "";
154
155   my sub after {
156      $x .= "c";
157   }
158
159   my sub before {
160      $x .= "a";
161      defer { $x .= "b" }
162      goto \&after;
163   }
164
165   before();
166
167   is($x, "abc", 'defer block invoked before tail-call');
168}
169
170# Sequencing with respect to variable cleanup
171
172{
173    my $var = "outer";
174    my $x;
175    {
176        my $var = "inner";
177        defer { $x = $var }
178    }
179
180    is($x, "inner", 'defer block captures live value of same-scope lexicals');
181}
182
183{
184    my $var = "outer";
185    my $x;
186    {
187        defer { $x = $var }
188        my $var = "inner";
189    }
190
191    is ($x, "outer", 'defer block correctly captures outer lexical when only shadowed afterwards');
192}
193
194{
195    our $var = "outer";
196    {
197        local $var = "inner";
198        defer { $var = "finally" }
199    }
200
201    is($var, "outer", 'defer after localization still unlocalizes');
202}
203
204{
205    our $var = "outer";
206    {
207        defer { $var = "finally" }
208        local $var = "inner";
209    }
210
211    is($var, "finally", 'defer before localization overwrites');
212}
213
214# Interactions with exceptions
215
216{
217    my $x = "";
218    my $sub = sub {
219        defer { $x .= "a" }
220        die "Oopsie\n";
221    };
222
223    my $e = defined eval { $sub->(); 1 } ? undef : $@;
224
225    is($x, "a", 'defer block still runs during exception unwind');
226    is($e, "Oopsie\n", 'Thrown exception still occurs after defer');
227}
228
229{
230    my $sub = sub {
231        defer { die "Oopsie\n"; }
232        return "retval";
233    };
234
235    my $e = defined eval { $sub->(); 1 } ? undef : $@;
236
237    is($e, "Oopsie\n", 'defer block can throw exception');
238}
239
240{
241    my $sub = sub {
242        defer { die "Oopsie 1\n"; }
243        die "Oopsie 2\n";
244    };
245
246    my $e = defined eval { $sub->(); 1 } ? undef : $@;
247
248    # TODO: Currently the first exception gets lost without even a warning
249    #   We should consider what the behaviour ought to be here
250    # This test is happy for either exception to be seen, does not care which
251    like($e, qr/^Oopsie \d\n/, 'defer block can throw exception during exception unwind');
252}
253
254{
255    my $sub = sub {
256        while(1) {
257            defer { return "retval" }
258            last;
259        }
260        return "wrong";
261    };
262
263    my $e = defined eval { $sub->(); 1 } ? undef : $@;
264    like($e, qr/^Can't "return" out of a defer block /,
265        'Cannot return out of defer block');
266}
267
268{
269    my $sub = sub {
270        while(1) {
271            defer { goto HERE }
272        }
273        HERE:
274    };
275
276    my $e = defined eval { $sub->(); 1 } ? undef : $@;
277    like($e, qr/^Can't "goto" out of a defer block /,
278        'Cannot goto out of defer block');
279}
280
281{
282    my $subA = sub {
283        my $subB = sub {};
284        while(1) {
285            defer { goto &$subB }
286        }
287    };
288
289    my $e = defined eval { $subA->(); 1 } ? undef : $@;
290    like($e, qr/^Can't "goto" out of a defer block at /,
291        'Cannot goto &SUB out of a defer block');
292}
293
294{
295    my $sub = sub {
296        LOOP: while(1) {
297            defer { last LOOP }
298        }
299    };
300
301    my $e = defined eval { $sub->(); 1 } ? undef : $@;
302    like($e, qr/^Can't "last" out of a defer block /,
303        'Cannot last out of defer block');
304}
305
306{
307    # strictness failures are only checked at optree finalization time. This
308    # is a good way to test if that happens.
309    my $ok = eval 'defer { use strict; foo }';
310    my $e = $@;
311
312    ok(!$ok, 'defer BLOCK finalizes optree');
313    like($e, qr/^Bareword "foo" not allowed while "strict subs" in use at /,
314        'Error from finalization');
315}
316