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