Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
8990e307 LW |
3 | # "This IS structured code. It's just randomly structured." |
4 | ||
971ecbe6 DM |
5 | BEGIN { |
6 | chdir 't' if -d 't'; | |
7 | @INC = qw(. ../lib); | |
7376f93f | 8 | require "test.pl"; |
971ecbe6 DM |
9 | } |
10 | ||
7376f93f DM |
11 | use warnings; |
12 | use strict; | |
0df5f63f SP |
13 | plan tests => 58; |
14 | our $TODO; | |
ba9ff06f | 15 | |
7376f93f | 16 | our $foo; |
79072805 | 17 | while ($?) { |
8d063cd8 LW |
18 | $foo = 1; |
19 | label1: | |
20 | $foo = 2; | |
21 | goto label2; | |
22 | } continue { | |
23 | $foo = 0; | |
24 | goto label4; | |
25 | label3: | |
26 | $foo = 4; | |
27 | goto label4; | |
28 | } | |
29 | goto label1; | |
30 | ||
31 | $foo = 3; | |
32 | ||
33 | label2: | |
7376f93f | 34 | is($foo, 2, 'escape while loop'); |
8d063cd8 LW |
35 | goto label3; |
36 | ||
37 | label4: | |
7376f93f | 38 | is($foo, 4, 'second escape while loop'); |
8d063cd8 | 39 | |
7376f93f DM |
40 | my $r = run_perl(prog => 'goto foo;', stderr => 1); |
41 | like($r, qr/label/, 'cant find label'); | |
79072805 | 42 | |
7376f93f | 43 | my $ok = 0; |
79072805 LW |
44 | sub foo { |
45 | goto bar; | |
79072805 LW |
46 | return; |
47 | bar: | |
7376f93f | 48 | $ok = 1; |
79072805 LW |
49 | } |
50 | ||
51 | &foo; | |
7376f93f | 52 | ok($ok, 'goto in sub'); |
79072805 LW |
53 | |
54 | sub bar { | |
7376f93f | 55 | my $x = 'bypass'; |
8990e307 | 56 | eval "goto $x"; |
79072805 LW |
57 | } |
58 | ||
59 | &bar; | |
60 | exit; | |
8990e307 LW |
61 | |
62 | FINALE: | |
7376f93f | 63 | is(curr_test(), 16, 'FINALE'); |
2c15bef3 GS |
64 | |
65 | # does goto LABEL handle block contexts correctly? | |
ba9ff06f JC |
66 | # note that this scope-hopping differs from last & next, |
67 | # which always go up-scope strictly. | |
7376f93f | 68 | my $count = 0; |
2c15bef3 GS |
69 | my $cond = 1; |
70 | for (1) { | |
71 | if ($cond == 1) { | |
72 | $cond = 0; | |
73 | goto OTHER; | |
74 | } | |
75 | elsif ($cond == 0) { | |
76 | OTHER: | |
77 | $cond = 2; | |
7376f93f DM |
78 | is($count, 0, 'OTHER'); |
79 | $count++; | |
2c15bef3 GS |
80 | goto THIRD; |
81 | } | |
82 | else { | |
83 | THIRD: | |
7376f93f DM |
84 | is($count, 1, 'THIRD'); |
85 | $count++; | |
2c15bef3 GS |
86 | } |
87 | } | |
7376f93f | 88 | is($count, 2, 'end of loop'); |
36c66720 RH |
89 | |
90 | # Does goto work correctly within a for(;;) loop? | |
91 | # (BUG ID 20010309.004) | |
92 | ||
93 | for(my $i=0;!$i++;) { | |
94 | my $x=1; | |
95 | goto label; | |
7376f93f | 96 | label: is($x, 1, 'goto inside a for(;;) loop body from inside the body'); |
36c66720 RH |
97 | } |
98 | ||
99 | # Does goto work correctly going *to* a for(;;) loop? | |
100 | # (make sure it doesn't skip the initializer) | |
101 | ||
102 | my ($z, $y) = (0); | |
7376f93f DM |
103 | FORL1: for ($y=1; $z;) { |
104 | ok($y, 'goto a for(;;) loop, from outside (does initializer)'); | |
105 | goto TEST19} | |
106 | ($y,$z) = (0, 1); | |
36c66720 RH |
107 | goto FORL1; |
108 | ||
109 | # Even from within the loop? | |
36c66720 | 110 | TEST19: $z = 0; |
7376f93f | 111 | FORL2: for($y=1; 1;) { |
36c66720 | 112 | if ($z) { |
7376f93f | 113 | ok($y, 'goto a for(;;) loop, from inside (does initializer)'); |
36c66720 RH |
114 | last; |
115 | } | |
7376f93f | 116 | ($y, $z) = (0, 1); |
36c66720 RH |
117 | goto FORL2; |
118 | } | |
119 | ||
9c5794fe | 120 | # Does goto work correctly within a try block? |
7376f93f DM |
121 | # (BUG ID 20000313.004) - [perl #2359] |
122 | $ok = 0; | |
9c5794fe RH |
123 | eval { |
124 | my $variable = 1; | |
125 | goto LABEL20; | |
126 | LABEL20: $ok = 1 if $variable; | |
127 | }; | |
7376f93f DM |
128 | ok($ok, 'works correctly within a try block'); |
129 | is($@, "", '...and $@ not set'); | |
9c5794fe RH |
130 | |
131 | # And within an eval-string? | |
9c5794fe RH |
132 | $ok = 0; |
133 | eval q{ | |
134 | my $variable = 1; | |
135 | goto LABEL21; | |
136 | LABEL21: $ok = 1 if $variable; | |
137 | }; | |
7376f93f DM |
138 | ok($ok, 'works correctly within an eval string'); |
139 | is($@, "", '...and $@ still not set'); | |
9c5794fe RH |
140 | |
141 | ||
a4f3a277 RH |
142 | # Test that goto works in nested eval-string |
143 | $ok = 0; | |
144 | {eval q{ | |
145 | eval q{ | |
146 | goto LABEL22; | |
147 | }; | |
148 | $ok = 0; | |
149 | last; | |
150 | ||
151 | LABEL22: $ok = 1; | |
152 | }; | |
153 | $ok = 0 if $@; | |
154 | } | |
7376f93f | 155 | ok($ok, 'works correctly in a nested eval string'); |
a4f3a277 | 156 | |
33d34e4c AE |
157 | { |
158 | my $false = 0; | |
7376f93f | 159 | my $count; |
33d34e4c AE |
160 | |
161 | $ok = 0; | |
162 | { goto A; A: $ok = 1 } continue { } | |
7376f93f | 163 | ok($ok, '#20357 goto inside /{ } continue { }/ loop'); |
33d34e4c AE |
164 | |
165 | $ok = 0; | |
166 | { do { goto A; A: $ok = 1 } while $false } | |
7376f93f | 167 | ok($ok, '#20154 goto inside /do { } while ()/ loop'); |
33d34e4c AE |
168 | $ok = 0; |
169 | foreach(1) { goto A; A: $ok = 1 } continue { }; | |
7376f93f | 170 | ok($ok, 'goto inside /foreach () { } continue { }/ loop'); |
33d34e4c AE |
171 | |
172 | $ok = 0; | |
173 | sub a { | |
174 | A: { if ($false) { redo A; B: $ok = 1; redo A; } } | |
7376f93f | 175 | goto B unless $count++; |
33d34e4c AE |
176 | } |
177 | a(); | |
7376f93f | 178 | ok($ok, '#19061 loop label wiped away by goto'); |
33d34e4c AE |
179 | |
180 | $ok = 0; | |
7376f93f | 181 | my $p; |
33d34e4c | 182 | for ($p=1;$p && goto A;$p=0) { A: $ok = 1 } |
7376f93f | 183 | ok($ok, 'weird case of goto and for(;;) loop'); |
33d34e4c AE |
184 | } |
185 | ||
5023d17a DM |
186 | # bug #9990 - don't prematurely free the CV we're &going to. |
187 | ||
188 | sub f1 { | |
189 | my $x; | |
4269b21d | 190 | goto sub { $x=0; ok(1,"don't prematurely free CV\n") } |
5023d17a DM |
191 | } |
192 | f1(); | |
193 | ||
241416b8 DM |
194 | # bug #22181 - this used to coredump or make $x undefined, due to |
195 | # erroneous popping of the inner BLOCK context | |
196 | ||
7376f93f DM |
197 | undef $ok; |
198 | for ($count=0; $count<2; $count++) { | |
241416b8 DM |
199 | my $x = 1; |
200 | goto LABEL29; | |
201 | LABEL29: | |
7376f93f | 202 | $ok = $x; |
241416b8 | 203 | } |
7376f93f | 204 | is($ok, 1, 'goto in for(;;) with continuation'); |
241416b8 | 205 | |
971ecbe6 DM |
206 | # bug #22299 - goto in require doesn't find label |
207 | ||
1c25d394 | 208 | open my $f, ">Op_goto01.pm" or die; |
971ecbe6 DM |
209 | print $f <<'EOT'; |
210 | package goto01; | |
211 | goto YYY; | |
212 | die; | |
213 | YYY: print "OK\n"; | |
214 | 1; | |
215 | EOT | |
216 | close $f; | |
217 | ||
1c25d394 | 218 | $r = runperl(prog => 'use Op_goto01; print qq[DONE\n]'); |
971ecbe6 | 219 | is($r, "OK\nDONE\n", "goto within use-d file"); |
1c25d394 | 220 | unlink "Op_goto01.pm"; |
971ecbe6 | 221 | |
e3aba57a | 222 | # test for [perl #24108] |
7376f93f DM |
223 | $ok = 1; |
224 | $count = 0; | |
e3aba57a | 225 | sub i_return_a_label { |
7376f93f | 226 | $count++; |
e3aba57a RGS |
227 | return "returned_label"; |
228 | } | |
229 | eval { goto +i_return_a_label; }; | |
7376f93f DM |
230 | $ok = 0; |
231 | ||
232 | returned_label: | |
233 | is($count, 1, 'called i_return_a_label'); | |
234 | ok($ok, 'skipped to returned_label'); | |
971ecbe6 | 235 | |
ff0adf16 DM |
236 | # [perl #29708] - goto &foo could leave foo() at depth two with |
237 | # @_ == PL_sv_undef, causing a coredump | |
238 | ||
239 | ||
7376f93f | 240 | $r = runperl( |
ff0adf16 DM |
241 | prog => |
242 | 'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)', | |
243 | stderr => 1 | |
244 | ); | |
7376f93f | 245 | is($r, "ok\n", 'avoid pad without an @_'); |
ff0adf16 | 246 | |
ba9ff06f | 247 | goto moretests; |
7376f93f | 248 | fail('goto moretests'); |
8990e307 LW |
249 | exit; |
250 | ||
251 | bypass: | |
7376f93f DM |
252 | |
253 | is(curr_test(), 5, 'eval "goto $x"'); | |
8990e307 LW |
254 | |
255 | # Test autoloading mechanism. | |
256 | ||
257 | sub two { | |
7376f93f DM |
258 | my ($pack, $file, $line) = caller; # Should indicate original call stats. |
259 | is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE", | |
260 | 'autoloading mechanism.'); | |
8990e307 LW |
261 | } |
262 | ||
263 | sub one { | |
264 | eval <<'END'; | |
7376f93f DM |
265 | no warnings 'redefine'; |
266 | sub one { pass('sub one'); goto &two; fail('sub one tail'); } | |
8990e307 LW |
267 | END |
268 | goto &one; | |
269 | } | |
270 | ||
7376f93f DM |
271 | $::FILE = __FILE__; |
272 | $::LINE = __LINE__ + 1; | |
8990e307 LW |
273 | &one(1,2,3); |
274 | ||
7376f93f DM |
275 | { |
276 | my $wherever = 'NOWHERE'; | |
277 | eval { goto $wherever }; | |
278 | like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@'); | |
279 | } | |
8990e307 | 280 | |
62b1ebc2 GS |
281 | # see if a modified @_ propagates |
282 | { | |
7376f93f | 283 | my $i; |
62b1ebc2 | 284 | package Foo; |
7376f93f DM |
285 | sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); } |
286 | sub show { ::is(+@_, 5, "show $i",); } | |
62b1ebc2 | 287 | sub start { push @_, 1, "foo", {}; goto &show; } |
7376f93f | 288 | for (1..3) { $i = $_; start(bless([$_]), 'bar'); } |
62b1ebc2 GS |
289 | } |
290 | ||
379c5dcc GS |
291 | sub auto { |
292 | goto &loadit; | |
293 | } | |
294 | ||
7376f93f | 295 | sub AUTOLOAD { $ok = 1 if "@_" eq "foo" } |
379c5dcc | 296 | |
7376f93f DM |
297 | $ok = 0; |
298 | auto("foo"); | |
299 | ok($ok, 'autoload'); | |
379c5dcc | 300 | |
7376f93f DM |
301 | { |
302 | my $wherever = 'FINALE'; | |
303 | goto $wherever; | |
304 | } | |
305 | fail('goto $wherever'); | |
ba9ff06f JC |
306 | |
307 | moretests: | |
308 | # test goto duplicated labels. | |
309 | { | |
310 | my $z = 0; | |
ba9ff06f JC |
311 | eval { |
312 | $z = 0; | |
313 | for (0..1) { | |
314 | L4: # not outer scope | |
315 | $z += 10; | |
316 | last; | |
317 | } | |
318 | goto L4 if $z == 10; | |
319 | last; | |
320 | }; | |
7376f93f DM |
321 | like($@, qr/Can't "goto" into the middle of a foreach loop/, |
322 | 'catch goto middle of foreach'); | |
ba9ff06f JC |
323 | |
324 | $z = 0; | |
325 | # ambiguous label resolution (outer scope means endless loop!) | |
ba9ff06f JC |
326 | L1: |
327 | for my $x (0..1) { | |
328 | $z += 10; | |
7376f93f | 329 | is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)'); |
ba9ff06f JC |
330 | goto L1 unless $x; |
331 | $z += 10; | |
332 | L1: | |
7376f93f | 333 | is($z, 10, 'prefer same scope: second'); |
ba9ff06f JC |
334 | last; |
335 | } | |
336 | ||
ba9ff06f JC |
337 | $z = 0; |
338 | L2: | |
339 | { | |
340 | $z += 10; | |
7376f93f | 341 | is($z, 10, 'prefer this scope (block body) to outer scope (block entry)'); |
ba9ff06f JC |
342 | goto L2 if $z == 10; |
343 | $z += 10; | |
344 | L2: | |
7376f93f | 345 | is($z, 10, 'prefer this scope: second'); |
ba9ff06f JC |
346 | } |
347 | ||
348 | ||
349 | { | |
ba9ff06f JC |
350 | $z = 0; |
351 | while (1) { | |
352 | L3: # not inner scope | |
353 | $z += 10; | |
354 | last; | |
355 | } | |
7376f93f | 356 | is($z, 10, 'prefer this scope to inner scope'); |
ba9ff06f JC |
357 | goto L3 if $z == 10; |
358 | $z += 10; | |
359 | L3: # this scope ! | |
7376f93f | 360 | is($z, 10, 'prefer this scope to inner scope: second'); |
ba9ff06f JC |
361 | } |
362 | ||
363 | L4: # not outer scope | |
364 | { | |
ba9ff06f JC |
365 | $z = 0; |
366 | while (1) { | |
367 | L4: # not inner scope | |
368 | $z += 1; | |
369 | last; | |
370 | } | |
7376f93f | 371 | is($z, 1, 'prefer this scope to inner,outer scopes'); |
ba9ff06f JC |
372 | goto L4 if $z == 1; |
373 | $z += 10; | |
374 | L4: # this scope ! | |
7376f93f | 375 | is($z, 1, 'prefer this scope to inner,outer scopes: second'); |
ba9ff06f JC |
376 | } |
377 | ||
378 | { | |
7376f93f DM |
379 | my $loop = 0; |
380 | for my $x (0..1) { | |
ba9ff06f JC |
381 | L2: # without this, fails 1 (middle) out of 3 iterations |
382 | $z = 0; | |
383 | L2: | |
384 | $z += 10; | |
7376f93f DM |
385 | is($z, 10, |
386 | "same label, multiple times in same scope (choose 1st) $loop"); | |
ba9ff06f JC |
387 | goto L2 if $z == 10 and not $loop++; |
388 | } | |
389 | } | |
390 | } | |
391 | ||
a45cdc79 DM |
392 | # deep recursion with gotos eventually caused a stack reallocation |
393 | # which messed up buggy internals that didn't expect the stack to move | |
394 | ||
395 | sub recurse1 { | |
396 | unshift @_, "x"; | |
7376f93f | 397 | no warnings 'recursion'; |
a45cdc79 DM |
398 | goto &recurse2; |
399 | } | |
400 | sub recurse2 { | |
7376f93f | 401 | my $x = shift; |
a45cdc79 DM |
402 | $_[0] ? +1 + recurse1($_[0] - 1) : 0 |
403 | } | |
7376f93f | 404 | is(recurse1(500), 500, 'recursive goto &foo'); |
a45cdc79 | 405 | |
b1464ded DM |
406 | # [perl #32039] Chained goto &sub drops data too early. |
407 | ||
408 | sub a32039 { @_=("foo"); goto &b32039; } | |
409 | sub b32039 { goto &c32039; } | |
7376f93f | 410 | sub c32039 { is($_[0], 'foo', 'chained &goto') } |
b1464ded DM |
411 | a32039(); |
412 | ||
3a1b2b9e DM |
413 | # [perl #35214] next and redo re-entered the loop with the wrong cop, |
414 | # causing a subsequent goto to crash | |
415 | ||
416 | { | |
417 | my $r = runperl( | |
418 | stderr => 1, | |
419 | prog => | |
e9e3be28 | 420 | 'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)' |
3a1b2b9e | 421 | ); |
e9e3be28 | 422 | is($r, "ok\n", 'next and goto'); |
3a1b2b9e DM |
423 | |
424 | $r = runperl( | |
425 | stderr => 1, | |
426 | prog => | |
e9e3be28 | 427 | 'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)' |
3a1b2b9e | 428 | ); |
e9e3be28 | 429 | is($r, "ok\n", 'redo and goto'); |
3a1b2b9e | 430 | } |
b1464ded | 431 | |
c74ace89 | 432 | # goto &foo not allowed in evals |
a45cdc79 | 433 | |
c74ace89 DM |
434 | |
435 | sub null { 1 }; | |
436 | eval 'goto &null'; | |
437 | like($@, qr/Can't goto subroutine from an eval-string/, 'eval string'); | |
438 | eval { goto &null }; | |
439 | like($@, qr/Can't goto subroutine from an eval-block/, 'eval block'); | |
c5be5b4d DM |
440 | |
441 | # [perl #36521] goto &foo in warn handler could defeat recursion avoider | |
442 | ||
443 | { | |
444 | my $r = runperl( | |
445 | stderr => 1, | |
446 | prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);' | |
447 | ); | |
448 | like($r, qr/bar/, "goto &foo in warn"); | |
449 | } | |
0df5f63f SP |
450 | |
451 | TODO: { | |
21ebe9a6 | 452 | local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes"; |
0df5f63f SP |
453 | our $global = "unmodified"; |
454 | if ($global) { # true but not constant-folded | |
455 | local $global = "modified"; | |
456 | goto ELSE; | |
457 | } else { | |
458 | ELSE: is($global, "unmodified"); | |
459 | } | |
460 | } | |
461 |