This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
typo in perlre.pod
[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;
426a09cd 13plan tests => 78;
0df5f63f 14our $TODO;
ba9ff06f 15
b500e03b
GG
16my $deprecated = 0;
17local $SIG{__WARN__} = sub { if ($_[0] =~ m/jump into a construct/) { $deprecated++; } else { warn $_[0] } };
18
7376f93f 19our $foo;
79072805 20while ($?) {
8d063cd8
LW
21 $foo = 1;
22 label1:
b500e03b
GG
23 is($deprecated, 1);
24 $deprecated = 0;
8d063cd8
LW
25 $foo = 2;
26 goto label2;
27} continue {
28 $foo = 0;
29 goto label4;
30 label3:
b500e03b
GG
31 is($deprecated, 1);
32 $deprecated = 0;
8d063cd8
LW
33 $foo = 4;
34 goto label4;
35}
b500e03b 36is($deprecated, 0);
8d063cd8
LW
37goto label1;
38
39$foo = 3;
40
41label2:
7376f93f 42is($foo, 2, 'escape while loop');
b500e03b 43is($deprecated, 0);
8d063cd8
LW
44goto label3;
45
46label4:
7376f93f 47is($foo, 4, 'second escape while loop');
8d063cd8 48
7376f93f
DM
49my $r = run_perl(prog => 'goto foo;', stderr => 1);
50like($r, qr/label/, 'cant find label');
79072805 51
7376f93f 52my $ok = 0;
79072805
LW
53sub foo {
54 goto bar;
79072805
LW
55 return;
56bar:
7376f93f 57 $ok = 1;
79072805
LW
58}
59
60&foo;
7376f93f 61ok($ok, 'goto in sub');
79072805
LW
62
63sub bar {
7376f93f 64 my $x = 'bypass';
8990e307 65 eval "goto $x";
79072805
LW
66}
67
68&bar;
69exit;
8990e307
LW
70
71FINALE:
b500e03b 72is(curr_test(), 20, 'FINALE');
2c15bef3
GS
73
74# does goto LABEL handle block contexts correctly?
ba9ff06f
JC
75# note that this scope-hopping differs from last & next,
76# which always go up-scope strictly.
7376f93f 77my $count = 0;
2c15bef3
GS
78my $cond = 1;
79for (1) {
80 if ($cond == 1) {
81 $cond = 0;
82 goto OTHER;
83 }
84 elsif ($cond == 0) {
85 OTHER:
86 $cond = 2;
7376f93f
DM
87 is($count, 0, 'OTHER');
88 $count++;
2c15bef3
GS
89 goto THIRD;
90 }
91 else {
92 THIRD:
7376f93f
DM
93 is($count, 1, 'THIRD');
94 $count++;
2c15bef3
GS
95 }
96}
7376f93f 97is($count, 2, 'end of loop');
36c66720
RH
98
99# Does goto work correctly within a for(;;) loop?
100# (BUG ID 20010309.004)
101
102for(my $i=0;!$i++;) {
103 my $x=1;
104 goto label;
7376f93f 105 label: is($x, 1, 'goto inside a for(;;) loop body from inside the body');
36c66720
RH
106}
107
108# Does goto work correctly going *to* a for(;;) loop?
109# (make sure it doesn't skip the initializer)
110
111my ($z, $y) = (0);
7376f93f
DM
112FORL1: for ($y=1; $z;) {
113 ok($y, 'goto a for(;;) loop, from outside (does initializer)');
114 goto TEST19}
115($y,$z) = (0, 1);
36c66720
RH
116goto FORL1;
117
118# Even from within the loop?
36c66720 119TEST19: $z = 0;
7376f93f 120FORL2: for($y=1; 1;) {
36c66720 121 if ($z) {
7376f93f 122 ok($y, 'goto a for(;;) loop, from inside (does initializer)');
36c66720
RH
123 last;
124 }
7376f93f 125 ($y, $z) = (0, 1);
36c66720
RH
126 goto FORL2;
127}
128
9c5794fe 129# Does goto work correctly within a try block?
7376f93f
DM
130# (BUG ID 20000313.004) - [perl #2359]
131$ok = 0;
9c5794fe
RH
132eval {
133 my $variable = 1;
134 goto LABEL20;
135 LABEL20: $ok = 1 if $variable;
136};
7376f93f
DM
137ok($ok, 'works correctly within a try block');
138is($@, "", '...and $@ not set');
9c5794fe
RH
139
140# And within an eval-string?
9c5794fe
RH
141$ok = 0;
142eval q{
143 my $variable = 1;
144 goto LABEL21;
145 LABEL21: $ok = 1 if $variable;
146};
7376f93f
DM
147ok($ok, 'works correctly within an eval string');
148is($@, "", '...and $@ still not set');
9c5794fe
RH
149
150
a4f3a277
RH
151# Test that goto works in nested eval-string
152$ok = 0;
153{eval q{
154 eval q{
155 goto LABEL22;
156 };
157 $ok = 0;
158 last;
159
160 LABEL22: $ok = 1;
161};
162$ok = 0 if $@;
163}
7376f93f 164ok($ok, 'works correctly in a nested eval string');
a4f3a277 165
33d34e4c
AE
166{
167 my $false = 0;
7376f93f 168 my $count;
33d34e4c
AE
169
170 $ok = 0;
171 { goto A; A: $ok = 1 } continue { }
7376f93f 172 ok($ok, '#20357 goto inside /{ } continue { }/ loop');
33d34e4c
AE
173
174 $ok = 0;
175 { do { goto A; A: $ok = 1 } while $false }
7376f93f 176 ok($ok, '#20154 goto inside /do { } while ()/ loop');
33d34e4c
AE
177 $ok = 0;
178 foreach(1) { goto A; A: $ok = 1 } continue { };
7376f93f 179 ok($ok, 'goto inside /foreach () { } continue { }/ loop');
33d34e4c
AE
180
181 $ok = 0;
182 sub a {
183 A: { if ($false) { redo A; B: $ok = 1; redo A; } }
7376f93f 184 goto B unless $count++;
33d34e4c 185 }
b500e03b 186 is($deprecated, 0);
33d34e4c 187 a();
7376f93f 188 ok($ok, '#19061 loop label wiped away by goto');
b500e03b
GG
189 is($deprecated, 1);
190 $deprecated = 0;
33d34e4c
AE
191
192 $ok = 0;
7376f93f 193 my $p;
33d34e4c 194 for ($p=1;$p && goto A;$p=0) { A: $ok = 1 }
7376f93f 195 ok($ok, 'weird case of goto and for(;;) loop');
b500e03b
GG
196 is($deprecated, 1);
197 $deprecated = 0;
33d34e4c
AE
198}
199
5023d17a
DM
200# bug #9990 - don't prematurely free the CV we're &going to.
201
202sub f1 {
203 my $x;
4269b21d 204 goto sub { $x=0; ok(1,"don't prematurely free CV\n") }
5023d17a
DM
205}
206f1();
207
241416b8
DM
208# bug #22181 - this used to coredump or make $x undefined, due to
209# erroneous popping of the inner BLOCK context
210
7376f93f
DM
211undef $ok;
212for ($count=0; $count<2; $count++) {
241416b8
DM
213 my $x = 1;
214 goto LABEL29;
215 LABEL29:
7376f93f 216 $ok = $x;
241416b8 217}
7376f93f 218is($ok, 1, 'goto in for(;;) with continuation');
241416b8 219
971ecbe6
DM
220# bug #22299 - goto in require doesn't find label
221
1c25d394 222open my $f, ">Op_goto01.pm" or die;
971ecbe6
DM
223print $f <<'EOT';
224package goto01;
225goto YYY;
226die;
227YYY: print "OK\n";
2281;
229EOT
230close $f;
231
1c25d394 232$r = runperl(prog => 'use Op_goto01; print qq[DONE\n]');
971ecbe6 233is($r, "OK\nDONE\n", "goto within use-d file");
4d44d44a 234unlink_all "Op_goto01.pm";
971ecbe6 235
e3aba57a 236# test for [perl #24108]
7376f93f
DM
237$ok = 1;
238$count = 0;
e3aba57a 239sub i_return_a_label {
7376f93f 240 $count++;
e3aba57a
RGS
241 return "returned_label";
242}
243eval { goto +i_return_a_label; };
7376f93f
DM
244$ok = 0;
245
246returned_label:
247is($count, 1, 'called i_return_a_label');
248ok($ok, 'skipped to returned_label');
971ecbe6 249
ff0adf16
DM
250# [perl #29708] - goto &foo could leave foo() at depth two with
251# @_ == PL_sv_undef, causing a coredump
252
253
7376f93f 254$r = runperl(
ff0adf16
DM
255 prog =>
256 'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)',
257 stderr => 1
258 );
7376f93f 259is($r, "ok\n", 'avoid pad without an @_');
ff0adf16 260
ba9ff06f 261goto moretests;
7376f93f 262fail('goto moretests');
8990e307
LW
263exit;
264
265bypass:
7376f93f 266
b500e03b 267is(curr_test(), 9, 'eval "goto $x"');
8990e307
LW
268
269# Test autoloading mechanism.
270
271sub two {
7376f93f
DM
272 my ($pack, $file, $line) = caller; # Should indicate original call stats.
273 is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE",
274 'autoloading mechanism.');
8990e307
LW
275}
276
277sub one {
278 eval <<'END';
7376f93f
DM
279 no warnings 'redefine';
280 sub one { pass('sub one'); goto &two; fail('sub one tail'); }
8990e307
LW
281END
282 goto &one;
283}
284
7376f93f
DM
285$::FILE = __FILE__;
286$::LINE = __LINE__ + 1;
8990e307
LW
287&one(1,2,3);
288
7376f93f
DM
289{
290 my $wherever = 'NOWHERE';
291 eval { goto $wherever };
292 like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@');
293}
8990e307 294
62b1ebc2
GS
295# see if a modified @_ propagates
296{
7376f93f 297 my $i;
62b1ebc2 298 package Foo;
7376f93f
DM
299 sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); }
300 sub show { ::is(+@_, 5, "show $i",); }
62b1ebc2 301 sub start { push @_, 1, "foo", {}; goto &show; }
7376f93f 302 for (1..3) { $i = $_; start(bless([$_]), 'bar'); }
62b1ebc2
GS
303}
304
379c5dcc
GS
305sub auto {
306 goto &loadit;
307}
308
7376f93f 309sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
379c5dcc 310
7376f93f
DM
311$ok = 0;
312auto("foo");
313ok($ok, 'autoload');
379c5dcc 314
7376f93f
DM
315{
316 my $wherever = 'FINALE';
317 goto $wherever;
318}
319fail('goto $wherever');
ba9ff06f
JC
320
321moretests:
322# test goto duplicated labels.
323{
324 my $z = 0;
ba9ff06f
JC
325 eval {
326 $z = 0;
327 for (0..1) {
328 L4: # not outer scope
329 $z += 10;
330 last;
331 }
332 goto L4 if $z == 10;
333 last;
334 };
7376f93f
DM
335 like($@, qr/Can't "goto" into the middle of a foreach loop/,
336 'catch goto middle of foreach');
ba9ff06f
JC
337
338 $z = 0;
339 # ambiguous label resolution (outer scope means endless loop!)
ba9ff06f
JC
340 L1:
341 for my $x (0..1) {
342 $z += 10;
7376f93f 343 is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)');
ba9ff06f
JC
344 goto L1 unless $x;
345 $z += 10;
346 L1:
7376f93f 347 is($z, 10, 'prefer same scope: second');
ba9ff06f
JC
348 last;
349 }
350
ba9ff06f
JC
351 $z = 0;
352 L2:
353 {
354 $z += 10;
7376f93f 355 is($z, 10, 'prefer this scope (block body) to outer scope (block entry)');
ba9ff06f
JC
356 goto L2 if $z == 10;
357 $z += 10;
358 L2:
7376f93f 359 is($z, 10, 'prefer this scope: second');
ba9ff06f
JC
360 }
361
362
363 {
ba9ff06f
JC
364 $z = 0;
365 while (1) {
366 L3: # not inner scope
367 $z += 10;
368 last;
369 }
7376f93f 370 is($z, 10, 'prefer this scope to inner scope');
ba9ff06f
JC
371 goto L3 if $z == 10;
372 $z += 10;
373 L3: # this scope !
7376f93f 374 is($z, 10, 'prefer this scope to inner scope: second');
ba9ff06f
JC
375 }
376
377 L4: # not outer scope
378 {
ba9ff06f
JC
379 $z = 0;
380 while (1) {
381 L4: # not inner scope
382 $z += 1;
383 last;
384 }
7376f93f 385 is($z, 1, 'prefer this scope to inner,outer scopes');
ba9ff06f
JC
386 goto L4 if $z == 1;
387 $z += 10;
388 L4: # this scope !
7376f93f 389 is($z, 1, 'prefer this scope to inner,outer scopes: second');
ba9ff06f
JC
390 }
391
392 {
7376f93f
DM
393 my $loop = 0;
394 for my $x (0..1) {
ba9ff06f
JC
395 L2: # without this, fails 1 (middle) out of 3 iterations
396 $z = 0;
397 L2:
398 $z += 10;
7376f93f
DM
399 is($z, 10,
400 "same label, multiple times in same scope (choose 1st) $loop");
ba9ff06f
JC
401 goto L2 if $z == 10 and not $loop++;
402 }
403 }
404}
405
a45cdc79
DM
406# deep recursion with gotos eventually caused a stack reallocation
407# which messed up buggy internals that didn't expect the stack to move
408
409sub recurse1 {
410 unshift @_, "x";
7376f93f 411 no warnings 'recursion';
a45cdc79
DM
412 goto &recurse2;
413}
414sub recurse2 {
7376f93f 415 my $x = shift;
a45cdc79
DM
416 $_[0] ? +1 + recurse1($_[0] - 1) : 0
417}
426a09cd
FC
418my $w = 0;
419$SIG{__WARN__} = sub { ++$w };
7376f93f 420is(recurse1(500), 500, 'recursive goto &foo');
426a09cd
FC
421is $w, 0, 'no recursion warnings for "no warnings; goto &sub"';
422delete $SIG{__WARN__};
a45cdc79 423
b1464ded
DM
424# [perl #32039] Chained goto &sub drops data too early.
425
426sub a32039 { @_=("foo"); goto &b32039; }
427sub b32039 { goto &c32039; }
7376f93f 428sub c32039 { is($_[0], 'foo', 'chained &goto') }
b1464ded
DM
429a32039();
430
3a1b2b9e
DM
431# [perl #35214] next and redo re-entered the loop with the wrong cop,
432# causing a subsequent goto to crash
433
434{
435 my $r = runperl(
436 stderr => 1,
437 prog =>
e9e3be28 438'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)'
3a1b2b9e 439 );
e9e3be28 440 is($r, "ok\n", 'next and goto');
3a1b2b9e
DM
441
442 $r = runperl(
443 stderr => 1,
444 prog =>
e9e3be28 445'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)'
3a1b2b9e 446 );
e9e3be28 447 is($r, "ok\n", 'redo and goto');
3a1b2b9e 448}
b1464ded 449
c74ace89 450# goto &foo not allowed in evals
a45cdc79 451
c74ace89
DM
452
453sub null { 1 };
454eval 'goto &null';
455like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
456eval { goto &null };
457like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
c5be5b4d
DM
458
459# [perl #36521] goto &foo in warn handler could defeat recursion avoider
460
461{
462 my $r = runperl(
463 stderr => 1,
464 prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
465 );
466 like($r, qr/bar/, "goto &foo in warn");
467}
0df5f63f
SP
468
469TODO: {
21ebe9a6 470 local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes";
0df5f63f
SP
471 our $global = "unmodified";
472 if ($global) { # true but not constant-folded
473 local $global = "modified";
474 goto ELSE;
475 } else {
476 ELSE: is($global, "unmodified");
477 }
478}
479
b500e03b 480is($deprecated, 0);
47550813
NC
481
482#74290
483{
484 my $x;
485 my $y;
486 F1:++$x and eval 'return if ++$y == 10; goto F1;';
487 is($x, 10,
488 'labels outside evals can be distinguished from the start of the eval');
489}
ac56e7de
NC
490
491goto wham_eth;
492die "You can't get here";
493
494wham_eth: 1 if 0;
495ouch_eth: pass('labels persist even if their statement is optimised away');
5f211341
Z
496
497$foo = "(0)";
498if($foo eq $foo) {
499 goto bungo;
500}
501$foo .= "(9)";
502bungo:
503format CHOLET =
504wellington
505.
506$foo .= "(1)";
e77ae825
NC
507SKIP: {
508 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
509 my $cholet;
510 open(CHOLET, ">", \$cholet);
511 write CHOLET;
512 close CHOLET;
513 $foo .= "(".$cholet.")";
514 is($foo, "(0)(1)(wellington\n)", "label before format decl");
515}
5f211341
Z
516
517$foo = "(A)";
518if($foo eq $foo) {
519 goto orinoco;
520}
521$foo .= "(X)";
522orinoco:
523sub alderney { return "tobermory"; }
524$foo .= "(B)";
525$foo .= "(".alderney().")";
526is($foo, "(A)(B)(tobermory)", "label before sub decl");
527
528$foo = "[0:".__PACKAGE__."]";
529if($foo eq $foo) {
530 goto bulgaria;
531}
532$foo .= "[9]";
533bulgaria:
534package Tomsk;
535$foo .= "[1:".__PACKAGE__."]";
536$foo .= "[2:".__PACKAGE__."]";
537package main;
538$foo .= "[3:".__PACKAGE__."]";
539is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl");
540
541$foo = "[A:".__PACKAGE__."]";
542if($foo eq $foo) {
543 goto adelaide;
544}
545$foo .= "[Z]";
546adelaide:
547package Cairngorm {
548 $foo .= "[B:".__PACKAGE__."]";
549}
550$foo .= "[C:".__PACKAGE__."]";
551is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block");
552
553our $obidos;
554$foo = "{0}";
555if($foo eq $foo) {
556 goto shansi;
557}
558$foo .= "{9}";
559shansi:
560BEGIN { $obidos = "x"; }
561$foo .= "{1$obidos}";
562is($foo, "{0}{1x}", "label before BEGIN block");
563
564$foo = "{A:".(1.5+1.5)."}";
565if($foo eq $foo) {
566 goto stepney;
567}
568$foo .= "{Z}";
569stepney:
570use integer;
571$foo .= "{B:".(1.5+1.5)."}";
572is($foo, "{A:3}{B:2}", "label before use decl");
8e720305
Z
573
574$foo = "<0>";
575if($foo eq $foo) {
576 goto tom;
577}
578$foo .= "<9>";
579tom: dick: harry:
580$foo .= "<1>";
581$foo .= "<2>";
582is($foo, "<0><1><2>", "first of three stacked labels");
583
584$foo = "<A>";
585if($foo eq $foo) {
586 goto beta;
587}
588$foo .= "<Z>";
589alpha: beta: gamma:
590$foo .= "<B>";
591$foo .= "<C>";
592is($foo, "<A><B><C>", "second of three stacked labels");
593
594$foo = ",0.";
595if($foo eq $foo) {
596 goto gimel;
597}
598$foo .= ",9.";
599alef: bet: gimel:
600$foo .= ",1.";
601$foo .= ",2.";
602is($foo, ",0.,1.,2.", "third of three stacked labels");