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