This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix up change 31494
[perl5.git] / t / op / goto.t
CommitLineData
8d063cd8
LW
1#!./perl
2
8990e307
LW
3# "This IS structured code. It's just randomly structured."
4
971ecbe6
DM
5BEGIN {
6 chdir 't' if -d 't';
7 @INC = qw(. ../lib);
7376f93f 8 require "test.pl";
971ecbe6
DM
9}
10
7376f93f
DM
11use warnings;
12use strict;
0df5f63f
SP
13plan tests => 58;
14our $TODO;
ba9ff06f 15
7376f93f 16our $foo;
79072805 17while ($?) {
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}
29goto label1;
30
31$foo = 3;
32
33label2:
7376f93f 34is($foo, 2, 'escape while loop');
8d063cd8
LW
35goto label3;
36
37label4:
7376f93f 38is($foo, 4, 'second escape while loop');
8d063cd8 39
7376f93f
DM
40my $r = run_perl(prog => 'goto foo;', stderr => 1);
41like($r, qr/label/, 'cant find label');
79072805 42
7376f93f 43my $ok = 0;
79072805
LW
44sub foo {
45 goto bar;
79072805
LW
46 return;
47bar:
7376f93f 48 $ok = 1;
79072805
LW
49}
50
51&foo;
7376f93f 52ok($ok, 'goto in sub');
79072805
LW
53
54sub bar {
7376f93f 55 my $x = 'bypass';
8990e307 56 eval "goto $x";
79072805
LW
57}
58
59&bar;
60exit;
8990e307
LW
61
62FINALE:
7376f93f 63is(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 68my $count = 0;
2c15bef3
GS
69my $cond = 1;
70for (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 88is($count, 2, 'end of loop');
36c66720
RH
89
90# Does goto work correctly within a for(;;) loop?
91# (BUG ID 20010309.004)
92
93for(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
102my ($z, $y) = (0);
7376f93f
DM
103FORL1: 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
107goto FORL1;
108
109# Even from within the loop?
36c66720 110TEST19: $z = 0;
7376f93f 111FORL2: 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
123eval {
124 my $variable = 1;
125 goto LABEL20;
126 LABEL20: $ok = 1 if $variable;
127};
7376f93f
DM
128ok($ok, 'works correctly within a try block');
129is($@, "", '...and $@ not set');
9c5794fe
RH
130
131# And within an eval-string?
9c5794fe
RH
132$ok = 0;
133eval q{
134 my $variable = 1;
135 goto LABEL21;
136 LABEL21: $ok = 1 if $variable;
137};
7376f93f
DM
138ok($ok, 'works correctly within an eval string');
139is($@, "", '...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 155ok($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
188sub f1 {
189 my $x;
4269b21d 190 goto sub { $x=0; ok(1,"don't prematurely free CV\n") }
5023d17a
DM
191}
192f1();
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
197undef $ok;
198for ($count=0; $count<2; $count++) {
241416b8
DM
199 my $x = 1;
200 goto LABEL29;
201 LABEL29:
7376f93f 202 $ok = $x;
241416b8 203}
7376f93f 204is($ok, 1, 'goto in for(;;) with continuation');
241416b8 205
971ecbe6
DM
206# bug #22299 - goto in require doesn't find label
207
208open my $f, ">goto01.pm" or die;
209print $f <<'EOT';
210package goto01;
211goto YYY;
212die;
213YYY: print "OK\n";
2141;
215EOT
216close $f;
217
7376f93f 218$r = runperl(prog => 'use goto01; print qq[DONE\n]');
971ecbe6
DM
219is($r, "OK\nDONE\n", "goto within use-d file");
220unlink "goto01.pm";
221
e3aba57a 222# test for [perl #24108]
7376f93f
DM
223$ok = 1;
224$count = 0;
e3aba57a 225sub i_return_a_label {
7376f93f 226 $count++;
e3aba57a
RGS
227 return "returned_label";
228}
229eval { goto +i_return_a_label; };
7376f93f
DM
230$ok = 0;
231
232returned_label:
233is($count, 1, 'called i_return_a_label');
234ok($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 245is($r, "ok\n", 'avoid pad without an @_');
ff0adf16 246
ba9ff06f 247goto moretests;
7376f93f 248fail('goto moretests');
8990e307
LW
249exit;
250
251bypass:
7376f93f
DM
252
253is(curr_test(), 5, 'eval "goto $x"');
8990e307
LW
254
255# Test autoloading mechanism.
256
257sub 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
263sub one {
264 eval <<'END';
7376f93f
DM
265 no warnings 'redefine';
266 sub one { pass('sub one'); goto &two; fail('sub one tail'); }
8990e307
LW
267END
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
291sub auto {
292 goto &loadit;
293}
294
7376f93f 295sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
379c5dcc 296
7376f93f
DM
297$ok = 0;
298auto("foo");
299ok($ok, 'autoload');
379c5dcc 300
7376f93f
DM
301{
302 my $wherever = 'FINALE';
303 goto $wherever;
304}
305fail('goto $wherever');
ba9ff06f
JC
306
307moretests:
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
395sub recurse1 {
396 unshift @_, "x";
7376f93f 397 no warnings 'recursion';
a45cdc79
DM
398 goto &recurse2;
399}
400sub recurse2 {
7376f93f 401 my $x = shift;
a45cdc79
DM
402 $_[0] ? +1 + recurse1($_[0] - 1) : 0
403}
7376f93f 404is(recurse1(500), 500, 'recursive goto &foo');
a45cdc79 405
b1464ded
DM
406# [perl #32039] Chained goto &sub drops data too early.
407
408sub a32039 { @_=("foo"); goto &b32039; }
409sub b32039 { goto &c32039; }
7376f93f 410sub c32039 { is($_[0], 'foo', 'chained &goto') }
b1464ded
DM
411a32039();
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
435sub null { 1 };
436eval 'goto &null';
437like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
438eval { goto &null };
439like($@, 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
451TODO: {
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