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