This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #35214] SEGV when next is followed by a goto
[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 }
9
10 print "1..49\n";
11
12 require "test.pl";
13
14 $purpose; # update per test, and include in print ok's !
15
16 while ($?) {
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 }
28 goto label1;
29
30 $foo = 3;
31
32 label2:
33 print "#1\t:$foo: == 2\n";
34 if ($foo == 2) {print "ok 1\n";} else {print "not ok 1\n";}
35 goto label3;
36
37 label4:
38 print "#2\t:$foo: == 4\n";
39 if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";}
40
41 $PERL = ($^O eq 'MSWin32') ? '.\perl' : ($^O eq 'MacOS') ? $^X : ($^O eq 'NetWare') ? 'perl' : './perl';
42 $CMD = qq[$PERL -e "goto foo;" 2>&1 ];
43 $x = `$CMD`;
44
45 if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";}
46
47 sub foo {
48     goto bar;
49     print "not ok 4\n";
50     return;
51 bar:
52     print "ok 4\n";
53 }
54
55 &foo;
56
57 sub bar {
58     $x = 'bypass';
59     eval "goto $x";
60 }
61
62 &bar;
63 exit;
64
65 FINALE:
66 print "ok 13\n";
67
68 # does goto LABEL handle block contexts correctly?
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.
72 my $cond = 1;
73 for (1) {
74     if ($cond == 1) {
75         $cond = 0;
76         goto OTHER;
77     }
78     elsif ($cond == 0) {
79       OTHER:
80         $cond = 2;
81         print "ok 14 - $purpose\n";
82         goto THIRD;
83     }
84     else {
85       THIRD:
86         print "ok 15 - $purpose\n";
87     }
88 }
89 print "ok 16\n";
90
91 # Does goto work correctly within a for(;;) loop?
92 #  (BUG ID 20010309.004)
93
94 $purpose = 'goto inside a for(;;) loop body from inside the body';
95 for(my $i=0;!$i++;) {
96   my $x=1;
97   goto label;
98   label: print (defined $x?"ok ": "not ok ", "17 - $purpose\n")
99 }
100
101 # Does goto work correctly going *to* a for(;;) loop?
102 #  (make sure it doesn't skip the initializer)
103
104 $purpose = 'goto a for(;;) loop, from outside (does initializer)';
105 my ($z, $y) = (0);
106 FORL1: for($y="ok 18 - $purpose\n"; $z;) {print $y; goto TEST19}
107 ($y,$z) = ("not ok 18 - $purpose\n", 1);
108 goto FORL1;
109
110 # Even from within the loop?
111 TEST19: $z = 0;
112 $purpose = 'goto a for(;;) loop, from inside (does initializer)';
113 FORL2: for($y="ok 19 - $purpose\n"; 1;) {
114   if ($z) {
115     print $y;
116     last;
117   }
118   ($y, $z) = ("not ok 19 - $purpose\n", 1);
119   goto FORL2;
120 }
121
122 # Does goto work correctly within a try block?
123 #  (BUG ID 20000313.004)
124 $purpose = 'works correctly within a try block';
125 my $ok = 0;
126 eval {
127   my $variable = 1;
128   goto LABEL20;
129   LABEL20: $ok = 1 if $variable;
130 };
131 print ($ok&&!$@ ? "ok 20" : "not ok 20", " - $purpose\n");
132
133 # And within an eval-string?
134 $purpose = 'works correctly within an eval string';
135 $ok = 0;
136 eval q{
137   my $variable = 1;
138   goto LABEL21;
139   LABEL21: $ok = 1 if $variable;
140 };
141 print ($ok&&!$@ ? "ok" : "not ok", " 21 - $purpose\n");
142
143
144 # Test that goto works in nested eval-string
145 $purpose = 'works correctly in a nested eval string';
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 }
158 print ($ok ? "ok" : "not ok", " 22 - $purpose\n");
159
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
193 # bug #9990 - don't prematurely free the CV we're &going to.
194
195 sub f1 {
196     my $x;
197     goto sub { $x; print "ok 28 - don't prematurely free CV\n" }
198 }
199 f1();
200
201 # bug #22181 - this used to coredump or make $x undefined, due to
202 # erroneous popping of the inner BLOCK context
203
204 for ($i=0; $i<2; $i++) {
205     my $x = 1;
206     goto LABEL29;
207     LABEL29:
208     print "not " if !defined $x || $x != 1;
209 }
210 print "ok 29 - goto in for(;;) with continuation\n";
211
212 # bug #22299 - goto in require doesn't find label
213
214 open my $f, ">goto01.pm" or die;
215 print $f <<'EOT';
216 package goto01;
217 goto YYY;
218 die;
219 YYY: print "OK\n";
220 1;
221 EOT
222 close $f;
223
224 curr_test(30);
225 my $r = runperl(prog => 'use goto01; print qq[DONE\n]');
226 is($r, "OK\nDONE\n", "goto within use-d file"); 
227 unlink "goto01.pm";
228
229 # test for [perl #24108]
230 sub i_return_a_label {
231     print "ok 31 - i_return_a_label called\n";
232     return "returned_label";
233 }
234 eval { goto +i_return_a_label; };
235 print "not ";
236 returned_label : print "ok 32 - done to returned_label\n";
237
238 # [perl #29708] - goto &foo could leave foo() at depth two with
239 # @_ == PL_sv_undef, causing a coredump
240
241
242 my $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     );
247 print "not " if $r ne "ok\n";
248 print "ok 33 - avoid pad without an \@_\n";
249
250 goto moretests;
251 exit;
252
253 bypass:
254 $purpose = 'eval "goto $x"';
255 print "ok 5 - $purpose\n";
256
257 # Test autoloading mechanism.
258
259 sub two {
260     ($pack, $file, $line) = caller;     # Should indicate original call stats.
261     $purpose = 'autoloading mechanism.';
262     print "@_ $pack $file $line" eq "1 2 3 main $FILE $LINE"
263         ? "ok 7 - $purpose\n"
264         : "not ok 7 - $purpose\n";
265 }
266
267 sub one {
268     eval <<'END';
269     sub one { print "ok 6\n"; goto &two; print "not ok 6\n"; }
270 END
271     goto &one;
272 }
273
274 $FILE = __FILE__;
275 $LINE = __LINE__ + 1;
276 &one(1,2,3);
277
278 $purpose = 'goto NOWHERE sets $@';
279 $wherever = NOWHERE;
280 eval { goto $wherever };
281 print $@ =~ /Can't find label NOWHERE/
282  ? "ok 8 - $purpose\n" : "not ok 8 - $purpose\n"; #'
283
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
293 sub auto {
294     goto &loadit;
295 }
296
297 sub AUTOLOAD { print @_ }
298
299 auto("ok 12\n");
300
301 $wherever = FINALE;
302 goto $wherever;
303
304 moretests:
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
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
399 sub recurse1 {
400     unshift @_, "x";
401     goto &recurse2;
402 }
403 sub recurse2 {
404     $x = shift;
405     $_[0] ? +1 + recurse1($_[0] - 1) : 0
406 }
407 print "not " unless recurse1(500) == 500;
408 print "ok 46 - recursive goto &foo\n";
409
410 # [perl #32039] Chained goto &sub drops data too early. 
411
412 sub a32039 { @_=("foo"); goto &b32039; }
413 sub b32039 { goto &c32039; }
414 sub c32039 { print $_[0] eq 'foo' ? "" : "not ", "ok 47 - chained &goto\n" }
415 a32039();
416
417 # [perl #35214] next and redo re-entered the loop with the wrong cop,
418 # causing a subsequent goto to crash
419
420 {
421     my $r = runperl(
422                 stderr => 1,
423                 prog =>
424 'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok)'
425     );
426     $r =~ s/\n//g;
427     print "# r=$r\nnot " unless $r eq 'ok';
428     print "ok 48 - next and goto\n";
429
430     $r = runperl(
431                 stderr => 1,
432                 prog =>
433 'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok)'
434     );
435     $r =~ s/\n//g;
436     print "# r=$r\nnot " unless $r eq 'ok';
437     print "ok 49 - redo and goto\n";
438 }
439
440