1#!./perl
2
3# "This IS structured code.  It's just randomly structured."
4
5BEGIN {
6    chdir 't' if -d 't';
7    @INC = qw(. ../lib);
8    require "test.pl";
9}
10
11use warnings;
12use strict;
13plan tests => 57;
14
15our $foo;
16while ($?) {
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:
33is($foo, 2, 'escape while loop');
34goto label3;
35
36label4:
37is($foo, 4, 'second escape while loop');
38
39my $r = run_perl(prog => 'goto foo;', stderr => 1);
40like($r, qr/label/, 'cant find label');
41
42my $ok = 0;
43sub foo {
44    goto bar;
45    return;
46bar:
47    $ok = 1;
48}
49
50&foo;
51ok($ok, 'goto in sub');
52
53sub bar {
54    my $x = 'bypass';
55    eval "goto $x";
56}
57
58&bar;
59exit;
60
61FINALE:
62is(curr_test(), 16, 'FINALE');
63
64# does goto LABEL handle block contexts correctly?
65# note that this scope-hopping differs from last & next,
66# which always go up-scope strictly.
67my $count = 0;
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;
77	is($count, 0, 'OTHER');
78	$count++;
79	goto THIRD;
80    }
81    else {
82      THIRD:
83	is($count, 1, 'THIRD');
84	$count++;
85    }
86}
87is($count, 2, 'end of loop');
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;
95  label: is($x, 1, 'goto inside a for(;;) loop body from inside the body');
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);
102FORL1: for ($y=1; $z;) {
103    ok($y, 'goto a for(;;) loop, from outside (does initializer)');
104    goto TEST19}
105($y,$z) = (0, 1);
106goto FORL1;
107
108# Even from within the loop?
109TEST19: $z = 0;
110FORL2: for($y=1; 1;) {
111  if ($z) {
112    ok($y, 'goto a for(;;) loop, from inside (does initializer)');
113    last;
114  }
115  ($y, $z) = (0, 1);
116  goto FORL2;
117}
118
119# Does goto work correctly within a try block?
120#  (BUG ID 20000313.004) - [perl #2359]
121$ok = 0;
122eval {
123  my $variable = 1;
124  goto LABEL20;
125  LABEL20: $ok = 1 if $variable;
126};
127ok($ok, 'works correctly within a try block');
128is($@, "", '...and $@ not set');
129
130# And within an eval-string?
131$ok = 0;
132eval q{
133  my $variable = 1;
134  goto LABEL21;
135  LABEL21: $ok = 1 if $variable;
136};
137ok($ok, 'works correctly within an eval string');
138is($@, "", '...and $@ still not set');
139
140
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}
154ok($ok, 'works correctly in a nested eval string');
155
156{
157    my $false = 0;
158    my $count;
159
160    $ok = 0;
161    { goto A; A: $ok = 1 } continue { }
162    ok($ok, '#20357 goto inside /{ } continue { }/ loop');
163
164    $ok = 0;
165    { do { goto A; A: $ok = 1 } while $false }
166    ok($ok, '#20154 goto inside /do { } while ()/ loop');
167    $ok = 0;
168    foreach(1) { goto A; A: $ok = 1 } continue { };
169    ok($ok, 'goto inside /foreach () { } continue { }/ loop');
170
171    $ok = 0;
172    sub a {
173	A: { if ($false) { redo A; B: $ok = 1; redo A; } }
174	goto B unless $count++;
175    }
176    a();
177    ok($ok, '#19061 loop label wiped away by goto');
178
179    $ok = 0;
180    my $p;
181    for ($p=1;$p && goto A;$p=0) { A: $ok = 1 }
182    ok($ok, 'weird case of goto and for(;;) loop');
183}
184
185# bug #9990 - don't prematurely free the CV we're &going to.
186
187sub f1 {
188    my $x;
189    goto sub { $x=0; ok(1,"don't prematurely free CV\n") }
190}
191f1();
192
193# bug #22181 - this used to coredump or make $x undefined, due to
194# erroneous popping of the inner BLOCK context
195
196undef $ok;
197for ($count=0; $count<2; $count++) {
198    my $x = 1;
199    goto LABEL29;
200    LABEL29:
201    $ok = $x;
202}
203is($ok, 1, 'goto in for(;;) with continuation');
204
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
217$r = runperl(prog => 'use goto01; print qq[DONE\n]');
218is($r, "OK\nDONE\n", "goto within use-d file");
219unlink "goto01.pm";
220
221# test for [perl #24108]
222$ok = 1;
223$count = 0;
224sub i_return_a_label {
225    $count++;
226    return "returned_label";
227}
228eval { goto +i_return_a_label; };
229$ok = 0;
230
231returned_label:
232is($count, 1, 'called i_return_a_label');
233ok($ok, 'skipped to returned_label');
234
235# [perl #29708] - goto &foo could leave foo() at depth two with
236# @_ == PL_sv_undef, causing a coredump
237
238
239$r = runperl(
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    );
244is($r, "ok\n", 'avoid pad without an @_');
245
246goto moretests;
247fail('goto moretests');
248exit;
249
250bypass:
251
252is(curr_test(), 5, 'eval "goto $x"');
253
254# Test autoloading mechanism.
255
256sub two {
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.');
260}
261
262sub one {
263    eval <<'END';
264    no warnings 'redefine';
265    sub one { pass('sub one'); goto &two; fail('sub one tail'); }
266END
267    goto &one;
268}
269
270$::FILE = __FILE__;
271$::LINE = __LINE__ + 1;
272&one(1,2,3);
273
274{
275    my $wherever = 'NOWHERE';
276    eval { goto $wherever };
277    like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@');
278}
279
280# see if a modified @_ propagates
281{
282  my $i;
283  package Foo;
284  sub DESTROY	{ my $s = shift; ::is($s->[0], $i, "destroy $i"); }
285  sub show	{ ::is(+@_, 5, "show $i",); }
286  sub start	{ push @_, 1, "foo", {}; goto &show; }
287  for (1..3)	{ $i = $_; start(bless([$_]), 'bar'); }
288}
289
290sub auto {
291    goto &loadit;
292}
293
294sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
295
296$ok = 0;
297auto("foo");
298ok($ok, 'autoload');
299
300{
301    my $wherever = 'FINALE';
302    goto $wherever;
303}
304fail('goto $wherever');
305
306moretests:
307# test goto duplicated labels.
308{
309    my $z = 0;
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    };
320    like($@, qr/Can't "goto" into the middle of a foreach loop/,
321	    'catch goto middle of foreach');
322
323    $z = 0;
324    # ambiguous label resolution (outer scope means endless loop!)
325  L1:
326    for my $x (0..1) {
327	$z += 10;
328	is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)');
329	goto L1 unless $x;
330	$z += 10;
331      L1:
332	is($z, 10, 'prefer same scope: second');
333	last;
334    }
335
336    $z = 0;
337  L2:
338    {
339	$z += 10;
340	is($z, 10, 'prefer this scope (block body) to outer scope (block entry)');
341	goto L2 if $z == 10;
342	$z += 10;
343      L2:
344	is($z, 10, 'prefer this scope: second');
345    }
346
347
348    {
349	$z = 0;
350	while (1) {
351	  L3: # not inner scope
352	    $z += 10;
353	    last;
354	}
355	is($z, 10, 'prefer this scope to inner scope');
356	goto L3 if $z == 10;
357	$z += 10;
358      L3: # this scope !
359	is($z, 10, 'prefer this scope to inner scope: second');
360    }
361
362  L4: # not outer scope
363    {
364	$z = 0;
365	while (1) {
366	  L4: # not inner scope
367	    $z += 1;
368	    last;
369	}
370	is($z, 1, 'prefer this scope to inner,outer scopes');
371	goto L4 if $z == 1;
372	$z += 10;
373      L4: # this scope !
374	is($z, 1, 'prefer this scope to inner,outer scopes: second');
375    }
376
377    {
378	my $loop = 0;
379	for my $x (0..1) {
380	  L2: # without this, fails 1 (middle) out of 3 iterations
381	    $z = 0;
382	  L2:
383	    $z += 10;
384	    is($z, 10,
385		"same label, multiple times in same scope (choose 1st) $loop");
386	    goto L2 if $z == 10 and not $loop++;
387	}
388    }
389}
390
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";
396    no warnings 'recursion';
397    goto &recurse2;
398}
399sub recurse2 {
400    my $x = shift;
401    $_[0] ? +1 + recurse1($_[0] - 1) : 0
402}
403is(recurse1(500), 500, 'recursive goto &foo');
404
405# [perl #32039] Chained goto &sub drops data too early.
406
407sub a32039 { @_=("foo"); goto &b32039; }
408sub b32039 { goto &c32039; }
409sub c32039 { is($_[0], 'foo', 'chained &goto') }
410a32039();
411
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 =>
419'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)'
420    );
421    is($r, "ok\n", 'next and goto');
422
423    $r = runperl(
424		stderr => 1,
425		prog =>
426'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)'
427    );
428    is($r, "ok\n", 'redo and goto');
429}
430
431# goto &foo not allowed in evals
432
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');
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}
449