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