Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
8990e307 LW |
3 | # "This IS structured code. It's just randomly structured." |
4 | ||
971ecbe6 DM |
5 | BEGIN { |
6 | chdir 't' if -d 't'; | |
7 | @INC = qw(. ../lib); | |
8 | } | |
9 | ||
b1464ded | 10 | print "1..47\n"; |
971ecbe6 DM |
11 | |
12 | require "test.pl"; | |
8d063cd8 | 13 | |
ba9ff06f JC |
14 | $purpose; # update per test, and include in print ok's ! |
15 | ||
79072805 | 16 | while ($?) { |
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 | } | |
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 | ||
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 | 45 | if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} |
79072805 LW |
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 { | |
8990e307 LW |
58 | $x = 'bypass'; |
59 | eval "goto $x"; | |
79072805 LW |
60 | } |
61 | ||
62 | &bar; | |
63 | exit; | |
8990e307 LW |
64 | |
65 | FINALE: | |
379c5dcc | 66 | print "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 |
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; | |
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 | } | |
89 | print "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 |
95 | for(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 | 105 | my ($z, $y) = (0); |
ba9ff06f JC |
106 | FORL1: for($y="ok 18 - $purpose\n"; $z;) {print $y; goto TEST19} |
107 | ($y,$z) = ("not ok 18 - $purpose\n", 1); | |
36c66720 RH |
108 | goto FORL1; |
109 | ||
110 | # Even from within the loop? | |
36c66720 | 111 | TEST19: $z = 0; |
ba9ff06f JC |
112 | $purpose = 'goto a for(;;) loop, from inside (does initializer)'; |
113 | FORL2: 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 |
125 | my $ok = 0; |
126 | eval { | |
127 | my $variable = 1; | |
128 | goto LABEL20; | |
129 | LABEL20: $ok = 1 if $variable; | |
130 | }; | |
ba9ff06f | 131 | print ($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; |
136 | eval q{ | |
137 | my $variable = 1; | |
138 | goto LABEL21; | |
139 | LABEL21: $ok = 1 if $variable; | |
140 | }; | |
ba9ff06f | 141 | print ($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 | 158 | print ($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 | ||
195 | sub f1 { | |
196 | my $x; | |
197 | goto sub { $x; print "ok 28 - don't prematurely free CV\n" } | |
198 | } | |
199 | f1(); | |
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 | ||
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 | ||
971ecbe6 DM |
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 | ||
e3aba57a RGS |
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"; | |
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 | ||
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 | ||
ba9ff06f | 250 | goto moretests; |
8990e307 LW |
251 | exit; |
252 | ||
253 | bypass: | |
ba9ff06f JC |
254 | $purpose = 'eval "goto $x"'; |
255 | print "ok 5 - $purpose\n"; | |
8990e307 LW |
256 | |
257 | # Test autoloading mechanism. | |
258 | ||
259 | sub 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 | ||
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 | ||
ba9ff06f | 278 | $purpose = 'goto NOWHERE sets $@'; |
8990e307 LW |
279 | $wherever = NOWHERE; |
280 | eval { goto $wherever }; | |
ba9ff06f JC |
281 | print $@ =~ /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 |
293 | sub auto { |
294 | goto &loadit; | |
295 | } | |
296 | ||
297 | sub AUTOLOAD { print @_ } | |
298 | ||
299 | auto("ok 12\n"); | |
300 | ||
8990e307 LW |
301 | $wherever = FINALE; |
302 | goto $wherever; | |
ba9ff06f JC |
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 | ||
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 | ||
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 | ||
b1464ded DM |
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 | ||
a45cdc79 | 418 |