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