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