Commit | Line | Data |
---|---|---|
f79e2ff9 PE |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | require './test.pl'; | |
6 | set_up_inc('../lib'); | |
7 | } | |
8 | ||
abf573d1 | 9 | plan 26; |
f79e2ff9 PE |
10 | |
11 | use feature 'defer'; | |
12 | no 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) { | |
315aa462 PE |
257 | goto HERE; |
258 | defer { HERE: 1; } | |
259 | } | |
260 | }; | |
261 | ||
262 | my $e = defined eval { $sub->(); 1 } ? undef : $@; | |
483cd949 | 263 | like($e, qr/^Can't "goto" into a "defer" block /, |
315aa462 PE |
264 | 'Cannot goto into defer block'); |
265 | } | |
266 | ||
267 | { | |
f79e2ff9 PE |
268 | # strictness failures are only checked at optree finalization time. This |
269 | # is a good way to test if that happens. | |
270 | my $ok = eval 'defer { use strict; foo }'; | |
271 | my $e = $@; | |
272 | ||
273 | ok(!$ok, 'defer BLOCK finalizes optree'); | |
274 | like($e, qr/^Bareword "foo" not allowed while "strict subs" in use at /, | |
275 | 'Error from finalization'); | |
276 | } |