This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/op/goto.t: Provide descriptions for remaining tests lacking them.
[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;
55b37f1c 13plan tests => 89;
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:
18bf01f6 23 is($deprecated, 1, "following label1");
b500e03b 24 $deprecated = 0;
8d063cd8
LW
25 $foo = 2;
26 goto label2;
27} continue {
28 $foo = 0;
29 goto label4;
30 label3:
18bf01f6 31 is($deprecated, 1, "following label3");
b500e03b 32 $deprecated = 0;
8d063cd8
LW
33 $foo = 4;
34 goto label4;
35}
18bf01f6 36is($deprecated, 0, "after 'while' loop");
8d063cd8
LW
37goto label1;
38
39$foo = 3;
40
41label2:
7376f93f 42is($foo, 2, 'escape while loop');
18bf01f6 43is($deprecated, 0, "following label2");
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 }
18bf01f6 186 is($deprecated, 0, "before calling sub a()");
33d34e4c 187 a();
7376f93f 188 ok($ok, '#19061 loop label wiped away by goto');
18bf01f6 189 is($deprecated, 1, "after calling sub a()");
b500e03b 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');
18bf01f6 196 is($deprecated, 1, "following goto and for(;;) loop");
b500e03b 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
1d59c038
FC
208# bug #99850, which is similar - freeing the subroutine we are about to
209# go(in)to during a FREETMPS call should not crash perl.
210
211package _99850 {
212 sub reftype{}
213 DESTROY { undef &reftype }
214 eval { sub { my $guard = bless []; goto &reftype }->() };
215}
216like $@, qr/^Goto undefined subroutine &_99850::reftype at /,
217 'goto &foo undefining &foo on sub cleanup';
218
241416b8
DM
219# bug #22181 - this used to coredump or make $x undefined, due to
220# erroneous popping of the inner BLOCK context
221
7376f93f
DM
222undef $ok;
223for ($count=0; $count<2; $count++) {
241416b8
DM
224 my $x = 1;
225 goto LABEL29;
226 LABEL29:
7376f93f 227 $ok = $x;
241416b8 228}
7376f93f 229is($ok, 1, 'goto in for(;;) with continuation');
241416b8 230
971ecbe6
DM
231# bug #22299 - goto in require doesn't find label
232
1c25d394 233open my $f, ">Op_goto01.pm" or die;
971ecbe6
DM
234print $f <<'EOT';
235package goto01;
236goto YYY;
237die;
238YYY: print "OK\n";
2391;
240EOT
241close $f;
242
1c25d394 243$r = runperl(prog => 'use Op_goto01; print qq[DONE\n]');
971ecbe6 244is($r, "OK\nDONE\n", "goto within use-d file");
4d44d44a 245unlink_all "Op_goto01.pm";
971ecbe6 246
e3aba57a 247# test for [perl #24108]
7376f93f
DM
248$ok = 1;
249$count = 0;
e3aba57a 250sub i_return_a_label {
7376f93f 251 $count++;
e3aba57a
RGS
252 return "returned_label";
253}
254eval { goto +i_return_a_label; };
7376f93f
DM
255$ok = 0;
256
257returned_label:
258is($count, 1, 'called i_return_a_label');
259ok($ok, 'skipped to returned_label');
971ecbe6 260
ff0adf16
DM
261# [perl #29708] - goto &foo could leave foo() at depth two with
262# @_ == PL_sv_undef, causing a coredump
263
264
7376f93f 265$r = runperl(
ff0adf16
DM
266 prog =>
267 'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)',
268 stderr => 1
269 );
7376f93f 270is($r, "ok\n", 'avoid pad without an @_');
ff0adf16 271
ba9ff06f 272goto moretests;
7376f93f 273fail('goto moretests');
8990e307
LW
274exit;
275
276bypass:
7376f93f 277
b500e03b 278is(curr_test(), 9, 'eval "goto $x"');
8990e307
LW
279
280# Test autoloading mechanism.
281
282sub two {
7376f93f
DM
283 my ($pack, $file, $line) = caller; # Should indicate original call stats.
284 is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE",
285 'autoloading mechanism.');
8990e307
LW
286}
287
288sub one {
289 eval <<'END';
7376f93f
DM
290 no warnings 'redefine';
291 sub one { pass('sub one'); goto &two; fail('sub one tail'); }
8990e307
LW
292END
293 goto &one;
294}
295
7376f93f
DM
296$::FILE = __FILE__;
297$::LINE = __LINE__ + 1;
8990e307
LW
298&one(1,2,3);
299
7376f93f
DM
300{
301 my $wherever = 'NOWHERE';
302 eval { goto $wherever };
303 like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@');
304}
8990e307 305
62b1ebc2
GS
306# see if a modified @_ propagates
307{
7376f93f 308 my $i;
62b1ebc2 309 package Foo;
7376f93f
DM
310 sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); }
311 sub show { ::is(+@_, 5, "show $i",); }
62b1ebc2 312 sub start { push @_, 1, "foo", {}; goto &show; }
7376f93f 313 for (1..3) { $i = $_; start(bless([$_]), 'bar'); }
62b1ebc2
GS
314}
315
379c5dcc
GS
316sub auto {
317 goto &loadit;
318}
319
7376f93f 320sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
379c5dcc 321
7376f93f
DM
322$ok = 0;
323auto("foo");
324ok($ok, 'autoload');
379c5dcc 325
7376f93f
DM
326{
327 my $wherever = 'FINALE';
328 goto $wherever;
329}
330fail('goto $wherever');
ba9ff06f
JC
331
332moretests:
333# test goto duplicated labels.
334{
335 my $z = 0;
ba9ff06f
JC
336 eval {
337 $z = 0;
338 for (0..1) {
339 L4: # not outer scope
340 $z += 10;
341 last;
342 }
343 goto L4 if $z == 10;
344 last;
345 };
7376f93f
DM
346 like($@, qr/Can't "goto" into the middle of a foreach loop/,
347 'catch goto middle of foreach');
ba9ff06f
JC
348
349 $z = 0;
350 # ambiguous label resolution (outer scope means endless loop!)
ba9ff06f
JC
351 L1:
352 for my $x (0..1) {
353 $z += 10;
7376f93f 354 is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)');
ba9ff06f
JC
355 goto L1 unless $x;
356 $z += 10;
357 L1:
7376f93f 358 is($z, 10, 'prefer same scope: second');
ba9ff06f
JC
359 last;
360 }
361
ba9ff06f
JC
362 $z = 0;
363 L2:
364 {
365 $z += 10;
7376f93f 366 is($z, 10, 'prefer this scope (block body) to outer scope (block entry)');
ba9ff06f
JC
367 goto L2 if $z == 10;
368 $z += 10;
369 L2:
7376f93f 370 is($z, 10, 'prefer this scope: second');
ba9ff06f
JC
371 }
372
373
374 {
ba9ff06f
JC
375 $z = 0;
376 while (1) {
377 L3: # not inner scope
378 $z += 10;
379 last;
380 }
7376f93f 381 is($z, 10, 'prefer this scope to inner scope');
ba9ff06f
JC
382 goto L3 if $z == 10;
383 $z += 10;
384 L3: # this scope !
7376f93f 385 is($z, 10, 'prefer this scope to inner scope: second');
ba9ff06f
JC
386 }
387
388 L4: # not outer scope
389 {
ba9ff06f
JC
390 $z = 0;
391 while (1) {
392 L4: # not inner scope
393 $z += 1;
394 last;
395 }
7376f93f 396 is($z, 1, 'prefer this scope to inner,outer scopes');
ba9ff06f
JC
397 goto L4 if $z == 1;
398 $z += 10;
399 L4: # this scope !
7376f93f 400 is($z, 1, 'prefer this scope to inner,outer scopes: second');
ba9ff06f
JC
401 }
402
403 {
7376f93f
DM
404 my $loop = 0;
405 for my $x (0..1) {
ba9ff06f
JC
406 L2: # without this, fails 1 (middle) out of 3 iterations
407 $z = 0;
408 L2:
409 $z += 10;
7376f93f
DM
410 is($z, 10,
411 "same label, multiple times in same scope (choose 1st) $loop");
ba9ff06f
JC
412 goto L2 if $z == 10 and not $loop++;
413 }
414 }
415}
416
a45cdc79
DM
417# deep recursion with gotos eventually caused a stack reallocation
418# which messed up buggy internals that didn't expect the stack to move
419
420sub recurse1 {
421 unshift @_, "x";
7376f93f 422 no warnings 'recursion';
a45cdc79
DM
423 goto &recurse2;
424}
425sub recurse2 {
7376f93f 426 my $x = shift;
a45cdc79
DM
427 $_[0] ? +1 + recurse1($_[0] - 1) : 0
428}
426a09cd
FC
429my $w = 0;
430$SIG{__WARN__} = sub { ++$w };
7376f93f 431is(recurse1(500), 500, 'recursive goto &foo');
426a09cd
FC
432is $w, 0, 'no recursion warnings for "no warnings; goto &sub"';
433delete $SIG{__WARN__};
a45cdc79 434
b1464ded
DM
435# [perl #32039] Chained goto &sub drops data too early.
436
437sub a32039 { @_=("foo"); goto &b32039; }
438sub b32039 { goto &c32039; }
7376f93f 439sub c32039 { is($_[0], 'foo', 'chained &goto') }
b1464ded
DM
440a32039();
441
3a1b2b9e
DM
442# [perl #35214] next and redo re-entered the loop with the wrong cop,
443# causing a subsequent goto to crash
444
445{
446 my $r = runperl(
447 stderr => 1,
448 prog =>
e9e3be28 449'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)'
3a1b2b9e 450 );
e9e3be28 451 is($r, "ok\n", 'next and goto');
3a1b2b9e
DM
452
453 $r = runperl(
454 stderr => 1,
455 prog =>
e9e3be28 456'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)'
3a1b2b9e 457 );
e9e3be28 458 is($r, "ok\n", 'redo and goto');
3a1b2b9e 459}
b1464ded 460
c74ace89 461# goto &foo not allowed in evals
a45cdc79 462
c74ace89
DM
463sub null { 1 };
464eval 'goto &null';
465like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
466eval { goto &null };
467like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
049bd5ff
FC
468
469# goto &foo leaves @_ alone when called from a sub
470sub returnarg { $_[0] };
471is sub {
472 local *_ = ["ick and queasy"];
473 goto &returnarg;
474}->("quick and easy"), "ick and queasy",
475 'goto &foo with *_{ARRAY} replaced';
476my @__ = "\xc4\x80";
477sub { local *_ = \@__; goto &utf8::decode }->("no thinking aloud");
478is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}';
479
480# And goto &foo should leave reified @_ alone
481sub { *__ = \@_; goto &null } -> ("rough and tubbery");
482is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone';
483
c5be5b4d
DM
484
485# [perl #36521] goto &foo in warn handler could defeat recursion avoider
486
487{
488 my $r = runperl(
489 stderr => 1,
490 prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
491 );
492 like($r, qr/bar/, "goto &foo in warn");
493}
0df5f63f
SP
494
495TODO: {
21ebe9a6 496 local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes";
0df5f63f
SP
497 our $global = "unmodified";
498 if ($global) { # true but not constant-folded
499 local $global = "modified";
500 goto ELSE;
501 } else {
502 ELSE: is($global, "unmodified");
503 }
504}
505
18bf01f6 506is($deprecated, 0, "following TODOed test for #43403");
47550813
NC
507
508#74290
509{
510 my $x;
511 my $y;
512 F1:++$x and eval 'return if ++$y == 10; goto F1;';
513 is($x, 10,
514 'labels outside evals can be distinguished from the start of the eval');
515}
ac56e7de
NC
516
517goto wham_eth;
518die "You can't get here";
519
520wham_eth: 1 if 0;
521ouch_eth: pass('labels persist even if their statement is optimised away');
5f211341
Z
522
523$foo = "(0)";
524if($foo eq $foo) {
525 goto bungo;
526}
527$foo .= "(9)";
528bungo:
529format CHOLET =
530wellington
531.
532$foo .= "(1)";
e77ae825
NC
533SKIP: {
534 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
535 my $cholet;
536 open(CHOLET, ">", \$cholet);
537 write CHOLET;
538 close CHOLET;
539 $foo .= "(".$cholet.")";
540 is($foo, "(0)(1)(wellington\n)", "label before format decl");
541}
5f211341
Z
542
543$foo = "(A)";
544if($foo eq $foo) {
545 goto orinoco;
546}
547$foo .= "(X)";
548orinoco:
549sub alderney { return "tobermory"; }
550$foo .= "(B)";
551$foo .= "(".alderney().")";
552is($foo, "(A)(B)(tobermory)", "label before sub decl");
553
554$foo = "[0:".__PACKAGE__."]";
555if($foo eq $foo) {
556 goto bulgaria;
557}
558$foo .= "[9]";
559bulgaria:
560package Tomsk;
561$foo .= "[1:".__PACKAGE__."]";
562$foo .= "[2:".__PACKAGE__."]";
563package main;
564$foo .= "[3:".__PACKAGE__."]";
565is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl");
566
567$foo = "[A:".__PACKAGE__."]";
568if($foo eq $foo) {
569 goto adelaide;
570}
571$foo .= "[Z]";
572adelaide:
573package Cairngorm {
574 $foo .= "[B:".__PACKAGE__."]";
575}
576$foo .= "[C:".__PACKAGE__."]";
577is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block");
578
579our $obidos;
580$foo = "{0}";
581if($foo eq $foo) {
582 goto shansi;
583}
584$foo .= "{9}";
585shansi:
586BEGIN { $obidos = "x"; }
587$foo .= "{1$obidos}";
588is($foo, "{0}{1x}", "label before BEGIN block");
589
590$foo = "{A:".(1.5+1.5)."}";
591if($foo eq $foo) {
592 goto stepney;
593}
594$foo .= "{Z}";
595stepney:
596use integer;
597$foo .= "{B:".(1.5+1.5)."}";
598is($foo, "{A:3}{B:2}", "label before use decl");
8e720305
Z
599
600$foo = "<0>";
601if($foo eq $foo) {
602 goto tom;
603}
604$foo .= "<9>";
605tom: dick: harry:
606$foo .= "<1>";
607$foo .= "<2>";
608is($foo, "<0><1><2>", "first of three stacked labels");
609
610$foo = "<A>";
611if($foo eq $foo) {
612 goto beta;
613}
614$foo .= "<Z>";
615alpha: beta: gamma:
616$foo .= "<B>";
617$foo .= "<C>";
618is($foo, "<A><B><C>", "second of three stacked labels");
619
620$foo = ",0.";
621if($foo eq $foo) {
622 goto gimel;
623}
624$foo .= ",9.";
625alef: bet: gimel:
626$foo .= ",1.";
627$foo .= ",2.";
628is($foo, ",0.,1.,2.", "third of three stacked labels");
eade7155
BF
629
630# [perl #112316] Wrong behavior regarding labels with same prefix
631sub same_prefix_labels {
632 my $pass;
633 my $first_time = 1;
634 CATCH: {
635 if ( $first_time ) {
636 CATCHLOOP: {
637 if ( !$first_time ) {
638 return 0;
639 }
640 $first_time--;
641 goto CATCH;
642 }
643 }
644 else {
645 return 1;
646 }
647 }
648}
649
650ok(
651 same_prefix_labels(),
652 "perl 112316: goto and labels with the same prefix doesn't get mixed up"
653);
c8f85248
FC
654
655eval { my $x = ""; goto $x };
656like $@, qr/^goto must have label at /, 'goto $x where $x is empty string';
657eval { goto "" };
658like $@, qr/^goto must have label at /, 'goto ""';
659eval { goto };
660like $@, qr/^goto must have label at /, 'argless goto';
3532f34a
FC
661
662eval { my $x = "\0"; goto $x };
663like $@, qr/^Can't find label \0 at /, 'goto $x where $x begins with \0';
664eval { goto "\0" };
665like $@, qr/^Can't find label \0 at /, 'goto "\0"';
55b37f1c
FC
666
667sub TIESCALAR { bless [pop] }
668sub FETCH { $_[0][0] }
669tie my $t, "", sub { "cluck up porridge" };
670is eval { sub { goto $t }->() }//$@, 'cluck up porridge',
671 'tied arg returning sub ref';