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