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'; | |
9a375827 | 7 | require "./test.pl"; require './charset_tools.pl'; |
624c42e2 | 8 | set_up_inc( qw(. ../lib) ); |
971ecbe6 DM |
9 | } |
10 | ||
7376f93f DM |
11 | use warnings; |
12 | use strict; | |
c1cc29fd | 13 | plan tests => 124; |
0df5f63f | 14 | our $TODO; |
ba9ff06f | 15 | |
b500e03b GG |
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 LW |
21 | $foo = 1; |
22 | label1: | |
18bf01f6 | 23 | is($deprecated, 1, "following label1"); |
b500e03b | 24 | $deprecated = 0; |
8d063cd8 LW |
25 | $foo = 2; |
26 | goto label2; | |
27 | } continue { | |
28 | $foo = 0; | |
29 | goto label4; | |
30 | label3: | |
18bf01f6 | 31 | is($deprecated, 1, "following label3"); |
b500e03b | 32 | $deprecated = 0; |
8d063cd8 LW |
33 | $foo = 4; |
34 | goto label4; | |
35 | } | |
18bf01f6 | 36 | is($deprecated, 0, "after 'while' loop"); |
8d063cd8 LW |
37 | goto label1; |
38 | ||
39 | $foo = 3; | |
40 | ||
41 | label2: | |
7376f93f | 42 | is($foo, 2, 'escape while loop'); |
18bf01f6 | 43 | is($deprecated, 0, "following label2"); |
8d063cd8 LW |
44 | goto label3; |
45 | ||
46 | label4: | |
7376f93f | 47 | is($foo, 4, 'second escape while loop'); |
8d063cd8 | 48 | |
7376f93f DM |
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 LW |
53 | sub foo { |
54 | goto bar; | |
79072805 LW |
55 | return; |
56 | bar: | |
7376f93f | 57 | $ok = 1; |
79072805 LW |
58 | } |
59 | ||
60 | &foo; | |
7376f93f | 61 | ok($ok, 'goto in sub'); |
79072805 LW |
62 | |
63 | sub bar { | |
7376f93f | 64 | my $x = 'bypass'; |
8990e307 | 65 | eval "goto $x"; |
79072805 LW |
66 | } |
67 | ||
68 | &bar; | |
69 | exit; | |
8990e307 LW |
70 | |
71 | FINALE: | |
b500e03b | 72 | is(curr_test(), 20, 'FINALE'); |
2c15bef3 GS |
73 | |
74 | # does goto LABEL handle block contexts correctly? | |
ba9ff06f JC |
75 | # note that this scope-hopping differs from last & next, |
76 | # which always go up-scope strictly. | |
7376f93f | 77 | my $count = 0; |
2c15bef3 GS |
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 DM |
87 | is($count, 0, 'OTHER'); |
88 | $count++; | |
2c15bef3 GS |
89 | goto THIRD; |
90 | } | |
91 | else { | |
92 | THIRD: | |
7376f93f DM |
93 | is($count, 1, 'THIRD'); |
94 | $count++; | |
2c15bef3 GS |
95 | } |
96 | } | |
7376f93f | 97 | is($count, 2, 'end of loop'); |
36c66720 RH |
98 | |
99 | # Does goto work correctly within a for(;;) loop? | |
ee95e30c | 100 | # (BUG ID 20010309.004 (#5998)) |
36c66720 RH |
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 RH |
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 DM |
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 RH |
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 RH |
123 | last; |
124 | } | |
7376f93f | 125 | ($y, $z) = (0, 1); |
36c66720 RH |
126 | goto FORL2; |
127 | } | |
128 | ||
9c5794fe | 129 | # Does goto work correctly within a try block? |
7376f93f DM |
130 | # (BUG ID 20000313.004) - [perl #2359] |
131 | $ok = 0; | |
9c5794fe RH |
132 | eval { |
133 | my $variable = 1; | |
134 | goto LABEL20; | |
135 | LABEL20: $ok = 1 if $variable; | |
136 | }; | |
7376f93f DM |
137 | ok($ok, 'works correctly within a try block'); |
138 | is($@, "", '...and $@ not set'); | |
9c5794fe RH |
139 | |
140 | # And within an eval-string? | |
9c5794fe RH |
141 | $ok = 0; |
142 | eval q{ | |
143 | my $variable = 1; | |
144 | goto LABEL21; | |
145 | LABEL21: $ok = 1 if $variable; | |
146 | }; | |
7376f93f DM |
147 | ok($ok, 'works correctly within an eval string'); |
148 | is($@, "", '...and $@ still not set'); | |
9c5794fe RH |
149 | |
150 | ||
a4f3a277 RH |
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 AE |
166 | { |
167 | my $false = 0; | |
7376f93f | 168 | my $count; |
33d34e4c AE |
169 | |
170 | $ok = 0; | |
171 | { goto A; A: $ok = 1 } continue { } | |
7376f93f | 172 | ok($ok, '#20357 goto inside /{ } continue { }/ loop'); |
33d34e4c AE |
173 | |
174 | $ok = 0; | |
175 | { do { goto A; A: $ok = 1 } while $false } | |
7376f93f | 176 | ok($ok, '#20154 goto inside /do { } while ()/ loop'); |
33d34e4c AE |
177 | $ok = 0; |
178 | foreach(1) { goto A; A: $ok = 1 } continue { }; | |
7376f93f | 179 | ok($ok, 'goto inside /foreach () { } continue { }/ loop'); |
33d34e4c AE |
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 | } |
18bf01f6 | 186 | is($deprecated, 0, "before calling sub a()"); |
33d34e4c | 187 | a(); |
7376f93f | 188 | ok($ok, '#19061 loop label wiped away by goto'); |
18bf01f6 | 189 | is($deprecated, 1, "after calling sub a()"); |
b500e03b | 190 | $deprecated = 0; |
33d34e4c AE |
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'); |
18bf01f6 | 196 | is($deprecated, 1, "following goto and for(;;) loop"); |
b500e03b | 197 | $deprecated = 0; |
33d34e4c AE |
198 | } |
199 | ||
5023d17a DM |
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 DM |
205 | } |
206 | f1(); | |
207 | ||
1d59c038 FC |
208 | # bug #99850, which is similar - freeing the subroutine we are about to |
209 | # go(in)to during a FREETMPS call should not crash perl. | |
210 | ||
211 | package _99850 { | |
212 | sub reftype{} | |
213 | DESTROY { undef &reftype } | |
214 | eval { sub { my $guard = bless []; goto &reftype }->() }; | |
215 | } | |
216 | like $@, qr/^Goto undefined subroutine &_99850::reftype at /, | |
217 | 'goto &foo undefining &foo on sub cleanup'; | |
218 | ||
cd17cc2e DM |
219 | # When croaking after discovering that the new CV you're about to goto is |
220 | # undef, make sure that the old CV isn't doubly freed. | |
221 | ||
222 | package Do_undef { | |
223 | my $count; | |
224 | ||
225 | # creating a new closure here encourages any prematurely freed | |
226 | # CV to be reallocated | |
227 | sub DESTROY { undef &undef_sub; my $x = sub { $count } } | |
228 | ||
229 | sub f { | |
230 | $count++; | |
231 | my $guard = bless []; # trigger DESTROY during goto | |
232 | *undef_sub = sub {}; | |
233 | goto &undef_sub | |
234 | } | |
235 | ||
236 | for (1..10) { | |
237 | eval { f() }; | |
238 | } | |
239 | ::is($count, 10, "goto undef_sub safe"); | |
240 | } | |
241 | ||
98ba6389 DM |
242 | # make sure that nothing nasty happens if the old CV is freed while |
243 | # goto'ing | |
244 | ||
245 | package Free_cv { | |
246 | my $results; | |
247 | sub f { | |
248 | no warnings 'redefine'; | |
249 | *f = sub {}; | |
250 | goto &g; | |
251 | } | |
252 | sub g { $results = "(@_)" } | |
253 | ||
254 | f(1,2,3); | |
255 | ::is($results, "(1 2 3)", "Free_cv"); | |
256 | } | |
257 | ||
cd17cc2e | 258 | |
241416b8 DM |
259 | # bug #22181 - this used to coredump or make $x undefined, due to |
260 | # erroneous popping of the inner BLOCK context | |
261 | ||
7376f93f DM |
262 | undef $ok; |
263 | for ($count=0; $count<2; $count++) { | |
241416b8 DM |
264 | my $x = 1; |
265 | goto LABEL29; | |
266 | LABEL29: | |
7376f93f | 267 | $ok = $x; |
241416b8 | 268 | } |
7376f93f | 269 | is($ok, 1, 'goto in for(;;) with continuation'); |
241416b8 | 270 | |
971ecbe6 DM |
271 | # bug #22299 - goto in require doesn't find label |
272 | ||
1c25d394 | 273 | open my $f, ">Op_goto01.pm" or die; |
971ecbe6 DM |
274 | print $f <<'EOT'; |
275 | package goto01; | |
276 | goto YYY; | |
277 | die; | |
278 | YYY: print "OK\n"; | |
279 | 1; | |
280 | EOT | |
281 | close $f; | |
282 | ||
3d7c117d | 283 | $r = runperl(prog => 'BEGIN { unshift @INC, q[.] } use Op_goto01; print qq[DONE\n]'); |
971ecbe6 | 284 | is($r, "OK\nDONE\n", "goto within use-d file"); |
4d44d44a | 285 | unlink_all "Op_goto01.pm"; |
971ecbe6 | 286 | |
e3aba57a | 287 | # test for [perl #24108] |
7376f93f DM |
288 | $ok = 1; |
289 | $count = 0; | |
e3aba57a | 290 | sub i_return_a_label { |
7376f93f | 291 | $count++; |
e3aba57a RGS |
292 | return "returned_label"; |
293 | } | |
294 | eval { goto +i_return_a_label; }; | |
7376f93f DM |
295 | $ok = 0; |
296 | ||
297 | returned_label: | |
298 | is($count, 1, 'called i_return_a_label'); | |
299 | ok($ok, 'skipped to returned_label'); | |
971ecbe6 | 300 | |
ff0adf16 DM |
301 | # [perl #29708] - goto &foo could leave foo() at depth two with |
302 | # @_ == PL_sv_undef, causing a coredump | |
303 | ||
304 | ||
7376f93f | 305 | $r = runperl( |
ff0adf16 DM |
306 | prog => |
307 | 'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)', | |
308 | stderr => 1 | |
309 | ); | |
7376f93f | 310 | is($r, "ok\n", 'avoid pad without an @_'); |
ff0adf16 | 311 | |
ba9ff06f | 312 | goto moretests; |
7376f93f | 313 | fail('goto moretests'); |
8990e307 LW |
314 | exit; |
315 | ||
316 | bypass: | |
7376f93f | 317 | |
b500e03b | 318 | is(curr_test(), 9, 'eval "goto $x"'); |
8990e307 LW |
319 | |
320 | # Test autoloading mechanism. | |
321 | ||
322 | sub two { | |
7376f93f DM |
323 | my ($pack, $file, $line) = caller; # Should indicate original call stats. |
324 | is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE", | |
325 | 'autoloading mechanism.'); | |
8990e307 LW |
326 | } |
327 | ||
328 | sub one { | |
329 | eval <<'END'; | |
7376f93f DM |
330 | no warnings 'redefine'; |
331 | sub one { pass('sub one'); goto &two; fail('sub one tail'); } | |
8990e307 LW |
332 | END |
333 | goto &one; | |
334 | } | |
335 | ||
7376f93f DM |
336 | $::FILE = __FILE__; |
337 | $::LINE = __LINE__ + 1; | |
8990e307 LW |
338 | &one(1,2,3); |
339 | ||
7376f93f DM |
340 | { |
341 | my $wherever = 'NOWHERE'; | |
342 | eval { goto $wherever }; | |
343 | like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@'); | |
344 | } | |
8990e307 | 345 | |
62b1ebc2 GS |
346 | # see if a modified @_ propagates |
347 | { | |
7376f93f | 348 | my $i; |
62b1ebc2 | 349 | package Foo; |
7376f93f DM |
350 | sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); } |
351 | sub show { ::is(+@_, 5, "show $i",); } | |
62b1ebc2 | 352 | sub start { push @_, 1, "foo", {}; goto &show; } |
7376f93f | 353 | for (1..3) { $i = $_; start(bless([$_]), 'bar'); } |
62b1ebc2 GS |
354 | } |
355 | ||
379c5dcc GS |
356 | sub auto { |
357 | goto &loadit; | |
358 | } | |
359 | ||
7376f93f | 360 | sub AUTOLOAD { $ok = 1 if "@_" eq "foo" } |
379c5dcc | 361 | |
7376f93f DM |
362 | $ok = 0; |
363 | auto("foo"); | |
364 | ok($ok, 'autoload'); | |
379c5dcc | 365 | |
7376f93f DM |
366 | { |
367 | my $wherever = 'FINALE'; | |
368 | goto $wherever; | |
369 | } | |
370 | fail('goto $wherever'); | |
ba9ff06f JC |
371 | |
372 | moretests: | |
373 | # test goto duplicated labels. | |
374 | { | |
375 | my $z = 0; | |
ba9ff06f JC |
376 | eval { |
377 | $z = 0; | |
378 | for (0..1) { | |
379 | L4: # not outer scope | |
380 | $z += 10; | |
381 | last; | |
382 | } | |
383 | goto L4 if $z == 10; | |
384 | last; | |
385 | }; | |
7376f93f DM |
386 | like($@, qr/Can't "goto" into the middle of a foreach loop/, |
387 | 'catch goto middle of foreach'); | |
ba9ff06f JC |
388 | |
389 | $z = 0; | |
390 | # ambiguous label resolution (outer scope means endless loop!) | |
ba9ff06f JC |
391 | L1: |
392 | for my $x (0..1) { | |
393 | $z += 10; | |
7376f93f | 394 | is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)'); |
ba9ff06f JC |
395 | goto L1 unless $x; |
396 | $z += 10; | |
397 | L1: | |
7376f93f | 398 | is($z, 10, 'prefer same scope: second'); |
ba9ff06f JC |
399 | last; |
400 | } | |
401 | ||
ba9ff06f JC |
402 | $z = 0; |
403 | L2: | |
404 | { | |
405 | $z += 10; | |
7376f93f | 406 | is($z, 10, 'prefer this scope (block body) to outer scope (block entry)'); |
ba9ff06f JC |
407 | goto L2 if $z == 10; |
408 | $z += 10; | |
409 | L2: | |
7376f93f | 410 | is($z, 10, 'prefer this scope: second'); |
ba9ff06f JC |
411 | } |
412 | ||
413 | ||
414 | { | |
ba9ff06f JC |
415 | $z = 0; |
416 | while (1) { | |
417 | L3: # not inner scope | |
418 | $z += 10; | |
419 | last; | |
420 | } | |
7376f93f | 421 | is($z, 10, 'prefer this scope to inner scope'); |
ba9ff06f JC |
422 | goto L3 if $z == 10; |
423 | $z += 10; | |
424 | L3: # this scope ! | |
7376f93f | 425 | is($z, 10, 'prefer this scope to inner scope: second'); |
ba9ff06f JC |
426 | } |
427 | ||
428 | L4: # not outer scope | |
429 | { | |
ba9ff06f JC |
430 | $z = 0; |
431 | while (1) { | |
432 | L4: # not inner scope | |
433 | $z += 1; | |
434 | last; | |
435 | } | |
7376f93f | 436 | is($z, 1, 'prefer this scope to inner,outer scopes'); |
ba9ff06f JC |
437 | goto L4 if $z == 1; |
438 | $z += 10; | |
439 | L4: # this scope ! | |
7376f93f | 440 | is($z, 1, 'prefer this scope to inner,outer scopes: second'); |
ba9ff06f JC |
441 | } |
442 | ||
443 | { | |
7376f93f DM |
444 | my $loop = 0; |
445 | for my $x (0..1) { | |
ba9ff06f JC |
446 | L2: # without this, fails 1 (middle) out of 3 iterations |
447 | $z = 0; | |
448 | L2: | |
449 | $z += 10; | |
7376f93f DM |
450 | is($z, 10, |
451 | "same label, multiple times in same scope (choose 1st) $loop"); | |
ba9ff06f JC |
452 | goto L2 if $z == 10 and not $loop++; |
453 | } | |
454 | } | |
455 | } | |
456 | ||
00bc5c85 NC |
457 | # This bug was introduced in Aug 2010 by commit ac56e7de46621c6f |
458 | # Peephole optimise adjacent pairs of nextstate ops. | |
459 | # and fixed in Oct 2014 by commit f5b5c2a37af87535 | |
460 | # Simplify double-nextstate optimisation | |
461 | ||
462 | # The bug manifests as a warning | |
463 | # Use of "goto" to jump into a construct is deprecated at t/op/goto.t line 442. | |
464 | # and $out is undefined. Devel::Peek reveals that the lexical in the pad has | |
465 | # been reset to undef. I infer that pp_goto thinks that it's leaving one scope | |
466 | # and entering another, but I don't know *why* it thinks that. Whilst this bug | |
467 | # has been fixed by Father C, because I don't understand why it happened, I am | |
468 | # not confident that other related bugs remain (or have always existed). | |
469 | ||
470 | sub DEBUG_TIME() { | |
471 | 0; | |
472 | } | |
473 | ||
474 | { | |
475 | if (DEBUG_TIME) { | |
476 | } | |
477 | ||
478 | { | |
479 | my $out = ""; | |
480 | $out .= 'perl rules'; | |
481 | goto no_list; | |
482 | no_list: | |
483 | is($out, 'perl rules', '$out has not been erroneously reset to undef'); | |
484 | }; | |
485 | } | |
486 | ||
487 | is($deprecated, 0, 'no warning was emmitted'); | |
488 | ||
a45cdc79 DM |
489 | # deep recursion with gotos eventually caused a stack reallocation |
490 | # which messed up buggy internals that didn't expect the stack to move | |
491 | ||
492 | sub recurse1 { | |
493 | unshift @_, "x"; | |
7376f93f | 494 | no warnings 'recursion'; |
a45cdc79 DM |
495 | goto &recurse2; |
496 | } | |
497 | sub recurse2 { | |
7376f93f | 498 | my $x = shift; |
a45cdc79 DM |
499 | $_[0] ? +1 + recurse1($_[0] - 1) : 0 |
500 | } | |
426a09cd FC |
501 | my $w = 0; |
502 | $SIG{__WARN__} = sub { ++$w }; | |
7376f93f | 503 | is(recurse1(500), 500, 'recursive goto &foo'); |
426a09cd FC |
504 | is $w, 0, 'no recursion warnings for "no warnings; goto &sub"'; |
505 | delete $SIG{__WARN__}; | |
a45cdc79 | 506 | |
b1464ded DM |
507 | # [perl #32039] Chained goto &sub drops data too early. |
508 | ||
509 | sub a32039 { @_=("foo"); goto &b32039; } | |
510 | sub b32039 { goto &c32039; } | |
7376f93f | 511 | sub c32039 { is($_[0], 'foo', 'chained &goto') } |
b1464ded DM |
512 | a32039(); |
513 | ||
3a1b2b9e DM |
514 | # [perl #35214] next and redo re-entered the loop with the wrong cop, |
515 | # causing a subsequent goto to crash | |
516 | ||
517 | { | |
518 | my $r = runperl( | |
519 | stderr => 1, | |
520 | prog => | |
e9e3be28 | 521 | 'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)' |
3a1b2b9e | 522 | ); |
e9e3be28 | 523 | is($r, "ok\n", 'next and goto'); |
3a1b2b9e DM |
524 | |
525 | $r = runperl( | |
526 | stderr => 1, | |
527 | prog => | |
e9e3be28 | 528 | 'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)' |
3a1b2b9e | 529 | ); |
e9e3be28 | 530 | is($r, "ok\n", 'redo and goto'); |
3a1b2b9e | 531 | } |
b1464ded | 532 | |
c74ace89 | 533 | # goto &foo not allowed in evals |
a45cdc79 | 534 | |
c74ace89 DM |
535 | sub null { 1 }; |
536 | eval 'goto &null'; | |
537 | like($@, qr/Can't goto subroutine from an eval-string/, 'eval string'); | |
538 | eval { goto &null }; | |
539 | like($@, qr/Can't goto subroutine from an eval-block/, 'eval block'); | |
049bd5ff FC |
540 | |
541 | # goto &foo leaves @_ alone when called from a sub | |
542 | sub returnarg { $_[0] }; | |
543 | is sub { | |
544 | local *_ = ["ick and queasy"]; | |
545 | goto &returnarg; | |
546 | }->("quick and easy"), "ick and queasy", | |
547 | 'goto &foo with *_{ARRAY} replaced'; | |
9a375827 | 548 | my @__ = byte_utf8a_to_utf8n("\xc4\x80"); |
049bd5ff FC |
549 | sub { local *_ = \@__; goto &utf8::decode }->("no thinking aloud"); |
550 | is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}'; | |
551 | ||
552 | # And goto &foo should leave reified @_ alone | |
553 | sub { *__ = \@_; goto &null } -> ("rough and tubbery"); | |
554 | is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone'; | |
555 | ||
dd2a7f90 FC |
556 | # goto &xsub when @_ has nonexistent elements |
557 | { | |
558 | no warnings "uninitialized"; | |
559 | local @_ = (); | |
560 | $#_++; | |
561 | & {sub { goto &utf8::encode }}; | |
562 | is @_, 1, 'num of elems in @_ after goto &xsub with nonexistent $_[0]'; | |
563 | is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub'; | |
564 | } | |
c5be5b4d | 565 | |
8c9d3376 FC |
566 | # goto &xsub when @_ itself does not exist |
567 | undef *_; | |
568 | eval { & { sub { goto &utf8::encode } } }; | |
569 | # The main thing we are testing is that it did not crash. But make sure | |
570 | # *_{ARRAY} was untouched, too. | |
571 | is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; | |
572 | ||
bfa371b6 FC |
573 | # goto &perlsub when @_ itself does not exist [perl #119949] |
574 | # This was only crashing when the replaced sub call had an argument list. | |
575 | # (I.e., &{ sub { goto ... } } did not crash.) | |
576 | sub { | |
577 | undef *_; | |
578 | goto sub { | |
579 | is *_{ARRAY}, undef, 'goto &perlsub when @_ does not exist'; | |
580 | } | |
581 | }->(); | |
582 | sub { | |
583 | local *_; | |
584 | goto sub { | |
585 | is *_{ARRAY}, undef, 'goto &sub when @_ does not exist (local *_)'; | |
586 | } | |
587 | }->(); | |
588 | ||
589 | ||
c5be5b4d DM |
590 | # [perl #36521] goto &foo in warn handler could defeat recursion avoider |
591 | ||
592 | { | |
593 | my $r = runperl( | |
594 | stderr => 1, | |
595 | prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);' | |
596 | ); | |
597 | like($r, qr/bar/, "goto &foo in warn"); | |
598 | } | |
0df5f63f SP |
599 | |
600 | TODO: { | |
21ebe9a6 | 601 | local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes"; |
0df5f63f SP |
602 | our $global = "unmodified"; |
603 | if ($global) { # true but not constant-folded | |
604 | local $global = "modified"; | |
605 | goto ELSE; | |
606 | } else { | |
607 | ELSE: is($global, "unmodified"); | |
608 | } | |
609 | } | |
610 | ||
18bf01f6 | 611 | is($deprecated, 0, "following TODOed test for #43403"); |
47550813 NC |
612 | |
613 | #74290 | |
614 | { | |
615 | my $x; | |
616 | my $y; | |
617 | F1:++$x and eval 'return if ++$y == 10; goto F1;'; | |
618 | is($x, 10, | |
619 | 'labels outside evals can be distinguished from the start of the eval'); | |
620 | } | |
ac56e7de NC |
621 | |
622 | goto wham_eth; | |
623 | die "You can't get here"; | |
624 | ||
625 | wham_eth: 1 if 0; | |
626 | ouch_eth: pass('labels persist even if their statement is optimised away'); | |
5f211341 Z |
627 | |
628 | $foo = "(0)"; | |
629 | if($foo eq $foo) { | |
630 | goto bungo; | |
631 | } | |
632 | $foo .= "(9)"; | |
633 | bungo: | |
634 | format CHOLET = | |
635 | wellington | |
636 | . | |
637 | $foo .= "(1)"; | |
e77ae825 NC |
638 | SKIP: { |
639 | skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); | |
640 | my $cholet; | |
641 | open(CHOLET, ">", \$cholet); | |
642 | write CHOLET; | |
643 | close CHOLET; | |
644 | $foo .= "(".$cholet.")"; | |
645 | is($foo, "(0)(1)(wellington\n)", "label before format decl"); | |
646 | } | |
5f211341 Z |
647 | |
648 | $foo = "(A)"; | |
649 | if($foo eq $foo) { | |
650 | goto orinoco; | |
651 | } | |
652 | $foo .= "(X)"; | |
653 | orinoco: | |
654 | sub alderney { return "tobermory"; } | |
655 | $foo .= "(B)"; | |
656 | $foo .= "(".alderney().")"; | |
657 | is($foo, "(A)(B)(tobermory)", "label before sub decl"); | |
658 | ||
659 | $foo = "[0:".__PACKAGE__."]"; | |
660 | if($foo eq $foo) { | |
661 | goto bulgaria; | |
662 | } | |
663 | $foo .= "[9]"; | |
664 | bulgaria: | |
665 | package Tomsk; | |
666 | $foo .= "[1:".__PACKAGE__."]"; | |
667 | $foo .= "[2:".__PACKAGE__."]"; | |
668 | package main; | |
669 | $foo .= "[3:".__PACKAGE__."]"; | |
670 | is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl"); | |
671 | ||
672 | $foo = "[A:".__PACKAGE__."]"; | |
673 | if($foo eq $foo) { | |
674 | goto adelaide; | |
675 | } | |
676 | $foo .= "[Z]"; | |
677 | adelaide: | |
678 | package Cairngorm { | |
679 | $foo .= "[B:".__PACKAGE__."]"; | |
680 | } | |
681 | $foo .= "[C:".__PACKAGE__."]"; | |
682 | is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block"); | |
683 | ||
684 | our $obidos; | |
685 | $foo = "{0}"; | |
686 | if($foo eq $foo) { | |
687 | goto shansi; | |
688 | } | |
689 | $foo .= "{9}"; | |
690 | shansi: | |
691 | BEGIN { $obidos = "x"; } | |
692 | $foo .= "{1$obidos}"; | |
693 | is($foo, "{0}{1x}", "label before BEGIN block"); | |
694 | ||
695 | $foo = "{A:".(1.5+1.5)."}"; | |
696 | if($foo eq $foo) { | |
697 | goto stepney; | |
698 | } | |
699 | $foo .= "{Z}"; | |
700 | stepney: | |
701 | use integer; | |
702 | $foo .= "{B:".(1.5+1.5)."}"; | |
703 | is($foo, "{A:3}{B:2}", "label before use decl"); | |
8e720305 Z |
704 | |
705 | $foo = "<0>"; | |
706 | if($foo eq $foo) { | |
707 | goto tom; | |
708 | } | |
709 | $foo .= "<9>"; | |
710 | tom: dick: harry: | |
711 | $foo .= "<1>"; | |
712 | $foo .= "<2>"; | |
713 | is($foo, "<0><1><2>", "first of three stacked labels"); | |
714 | ||
715 | $foo = "<A>"; | |
716 | if($foo eq $foo) { | |
717 | goto beta; | |
718 | } | |
719 | $foo .= "<Z>"; | |
720 | alpha: beta: gamma: | |
721 | $foo .= "<B>"; | |
722 | $foo .= "<C>"; | |
723 | is($foo, "<A><B><C>", "second of three stacked labels"); | |
724 | ||
725 | $foo = ",0."; | |
726 | if($foo eq $foo) { | |
727 | goto gimel; | |
728 | } | |
729 | $foo .= ",9."; | |
730 | alef: bet: gimel: | |
731 | $foo .= ",1."; | |
732 | $foo .= ",2."; | |
733 | is($foo, ",0.,1.,2.", "third of three stacked labels"); | |
eade7155 BF |
734 | |
735 | # [perl #112316] Wrong behavior regarding labels with same prefix | |
736 | sub same_prefix_labels { | |
737 | my $pass; | |
738 | my $first_time = 1; | |
739 | CATCH: { | |
740 | if ( $first_time ) { | |
741 | CATCHLOOP: { | |
742 | if ( !$first_time ) { | |
743 | return 0; | |
744 | } | |
745 | $first_time--; | |
746 | goto CATCH; | |
747 | } | |
748 | } | |
749 | else { | |
750 | return 1; | |
751 | } | |
752 | } | |
753 | } | |
754 | ||
755 | ok( | |
756 | same_prefix_labels(), | |
757 | "perl 112316: goto and labels with the same prefix doesn't get mixed up" | |
758 | ); | |
c8f85248 FC |
759 | |
760 | eval { my $x = ""; goto $x }; | |
761 | like $@, qr/^goto must have label at /, 'goto $x where $x is empty string'; | |
762 | eval { goto "" }; | |
763 | like $@, qr/^goto must have label at /, 'goto ""'; | |
764 | eval { goto }; | |
765 | like $@, qr/^goto must have label at /, 'argless goto'; | |
3532f34a FC |
766 | |
767 | eval { my $x = "\0"; goto $x }; | |
768 | like $@, qr/^Can't find label \0 at /, 'goto $x where $x begins with \0'; | |
769 | eval { goto "\0" }; | |
770 | like $@, qr/^Can't find label \0 at /, 'goto "\0"'; | |
55b37f1c FC |
771 | |
772 | sub TIESCALAR { bless [pop] } | |
773 | sub FETCH { $_[0][0] } | |
774 | tie my $t, "", sub { "cluck up porridge" }; | |
775 | is eval { sub { goto $t }->() }//$@, 'cluck up porridge', | |
776 | 'tied arg returning sub ref'; | |
3c37a496 DC |
777 | |
778 | TODO: { | |
779 | local $::TODO = 'RT #45091: goto in CORE::GLOBAL::exit unsupported'; | |
780 | fresh_perl_is(<<'EOC', "before\ndie handler\n", {stderr => 1}, 'RT #45091: goto in CORE::GLOBAL::EXIT'); | |
781 | BEGIN { | |
782 | *CORE::GLOBAL::exit = sub { | |
783 | goto FASTCGI_NEXT_REQUEST; | |
784 | }; | |
785 | } | |
786 | while (1) { | |
787 | eval { that_cgi_script() }; | |
788 | FASTCGI_NEXT_REQUEST: | |
789 | last; | |
790 | } | |
791 | ||
792 | sub that_cgi_script { | |
793 | local $SIG{__DIE__} = sub { print "die handler\n"; exit; print "exit failed?\n"; }; | |
794 | print "before\n"; | |
795 | eval { buggy_code() }; | |
796 | print "after\n"; | |
797 | } | |
798 | sub buggy_code { | |
799 | die "error!"; | |
800 | print "after die\n"; | |
801 | } | |
802 | EOC | |
803 | } | |
3c157b3c Z |
804 | |
805 | sub revnumcmp ($$) { | |
806 | goto FOO; | |
807 | die; | |
808 | FOO: | |
809 | return $_[1] <=> $_[0]; | |
810 | } | |
811 | is eval { join(":", sort revnumcmp (9,5,1,3,7)) }, "9:7:5:3:1", | |
812 | "can goto at top level of multicalled sub"; | |
6d90e983 FC |
813 | |
814 | # A bit strange, but goingto these constructs should not cause any stack | |
815 | # problems. Let’s test them to make sure that is the case. | |
816 | no warnings 'deprecated'; | |
817 | is \sub :lvalue { goto d; ${*{scalar(do { d: \*foo })}} }->(), \$foo, | |
818 | 'goto into rv2sv, rv2gv and scalar'; | |
819 | is sub { goto e; $#{; do { e: \@_ } } }->(1..7), 6, | |
820 | 'goto into $#{...}'; | |
821 | is sub { goto f; prototype \&{; do { f: sub ($) {} } } }->(), '$', | |
822 | 'goto into srefgen, prototype and rv2cv'; | |
823 | is sub { goto g; ref do { g: [] } }->(), 'ARRAY', | |
824 | 'goto into ref'; | |
825 | is sub { goto j; defined undef ${; do { j: \(my $foo = "foo") } } }->(),'', | |
826 | 'goto into defined and undef'; | |
827 | is sub { goto k; study ++${; do { k: \(my $foo = "foo") } } }->(),'1', | |
828 | 'goto into study and preincrement'; | |
829 | is sub { goto l; ~-!${; do { l: \(my $foo = 0) } }++ }->(),~-1, | |
830 | 'goto into complement, not, negation and postincrement'; | |
831 | like sub { goto n; sin cos exp log sqrt do { n: 1 } }->(),qr/^0\.51439/, | |
832 | 'goto into sin, cos, exp, log, and sqrt'; | |
833 | ok sub { goto o; srand do { o: 0 } }->(), | |
834 | 'goto into srand'; | |
835 | cmp_ok sub { goto p; rand do { p: 1 } }->(), '<', 1, | |
836 | 'goto into rand'; | |
837 | is sub { goto r; chr ord length int hex oct abs do { r: -15.5 } }->(), 2, | |
838 | 'goto into chr, ord, length, int, hex, oct and abs'; | |
839 | is sub { goto t; ucfirst lcfirst uc lc do { t: "q" } }->(), 'Q', | |
840 | 'goto into ucfirst, lcfirst, uc and lc'; | |
841 | { no strict; | |
842 | is sub { goto u; \@{; quotemeta do { u: "." } } }->(), \@{'\.'}, | |
843 | 'goto into rv2av and quotemeta'; | |
844 | } | |
845 | is join(" ",sub { goto v; %{; do { v: +{1..2} } } }->()), '1 2', | |
846 | 'goto into rv2hv'; | |
847 | is join(" ",sub { goto w; $_ || do { w: "w" } }->()), 'w', | |
848 | 'goto into rhs of or'; | |
849 | is join(" ",sub { goto x; $_ && do { x: "w" } }->()), 'w', | |
850 | 'goto into rhs of and'; | |
851 | is join(" ",sub { goto z; $_ ? do { z: "w" } : 0 }->()), 'w', | |
852 | 'goto into first leg of ?:'; | |
853 | is join(" ",sub { goto z; $_ ? 0 : do { z: "w" } }->()), 'w', | |
854 | 'goto into second leg of ?:'; | |
855 | is sub { goto z; caller do { z: 0 } }->(), 'main', | |
856 | 'goto into caller'; | |
857 | is sub { goto z; exit do { z: return "foo" } }->(), 'foo', | |
858 | 'goto into exit'; | |
859 | is sub { goto z; eval do { z: "'foo'" } }->(), 'foo', | |
860 | 'goto into eval'; | |
779ff8f4 CB |
861 | TODO: { |
862 | local $TODO = "glob() does not currently return a list on VMS" if $^O eq 'VMS'; | |
863 | is join(",",sub { goto z; glob do { z: "foo bar" } }->()), 'foo,bar', | |
864 | 'goto into glob'; | |
865 | } | |
4bfb5532 FC |
866 | # [perl #132799] |
867 | # Erroneous inward goto warning, followed by crash. | |
868 | # The eval must be in an assignment. | |
869 | sub _routine { | |
870 | my $e = eval { | |
871 | goto L2; | |
872 | L2: | |
873 | } | |
874 | } | |
875 | _routine(); | |
876 | pass("bug 132799"); | |
b4dcd72d FC |
877 | |
878 | # [perl #132854] | |
879 | # Goto the *first* parameter of a binary expression, which is harmless. | |
880 | eval { | |
881 | goto __GEN_2; | |
882 | my $sent = do { | |
883 | __GEN_2: | |
884 | }; | |
885 | }; | |
886 | is $@,'', 'goto the first parameter of a binary expression [perl #132854]'; |