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 => 94; 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, "following label1"); 24 $deprecated = 0; 25 $foo = 2; 26 goto label2; 27} continue { 28 $foo = 0; 29 goto label4; 30 label3: 31 is($deprecated, 1, "following label3"); 32 $deprecated = 0; 33 $foo = 4; 34 goto label4; 35} 36is($deprecated, 0, "after 'while' loop"); 37goto label1; 38 39$foo = 3; 40 41label2: 42is($foo, 2, 'escape while loop'); 43is($deprecated, 0, "following label2"); 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, "before calling sub a()"); 187 a(); 188 ok($ok, '#19061 loop label wiped away by goto'); 189 is($deprecated, 1, "after calling sub a()"); 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, "following goto and for(;;) loop"); 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 #99850, which is similar - freeing the subroutine we are about to 209# go(in)to during a FREETMPS call should not crash perl. 210 211package _99850 { 212 sub reftype{} 213 DESTROY { undef &reftype } 214 eval { sub { my $guard = bless []; goto &reftype }->() }; 215} 216like $@, qr/^Goto undefined subroutine &_99850::reftype at /, 217 'goto &foo undefining &foo on sub cleanup'; 218 219# bug #22181 - this used to coredump or make $x undefined, due to 220# erroneous popping of the inner BLOCK context 221 222undef $ok; 223for ($count=0; $count<2; $count++) { 224 my $x = 1; 225 goto LABEL29; 226 LABEL29: 227 $ok = $x; 228} 229is($ok, 1, 'goto in for(;;) with continuation'); 230 231# bug #22299 - goto in require doesn't find label 232 233open my $f, ">Op_goto01.pm" or die; 234print $f <<'EOT'; 235package goto01; 236goto YYY; 237die; 238YYY: print "OK\n"; 2391; 240EOT 241close $f; 242 243$r = runperl(prog => 'use Op_goto01; print qq[DONE\n]'); 244is($r, "OK\nDONE\n", "goto within use-d file"); 245unlink_all "Op_goto01.pm"; 246 247# test for [perl #24108] 248$ok = 1; 249$count = 0; 250sub i_return_a_label { 251 $count++; 252 return "returned_label"; 253} 254eval { goto +i_return_a_label; }; 255$ok = 0; 256 257returned_label: 258is($count, 1, 'called i_return_a_label'); 259ok($ok, 'skipped to returned_label'); 260 261# [perl #29708] - goto &foo could leave foo() at depth two with 262# @_ == PL_sv_undef, causing a coredump 263 264 265$r = runperl( 266 prog => 267 'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)', 268 stderr => 1 269 ); 270is($r, "ok\n", 'avoid pad without an @_'); 271 272goto moretests; 273fail('goto moretests'); 274exit; 275 276bypass: 277 278is(curr_test(), 9, 'eval "goto $x"'); 279 280# Test autoloading mechanism. 281 282sub two { 283 my ($pack, $file, $line) = caller; # Should indicate original call stats. 284 is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE", 285 'autoloading mechanism.'); 286} 287 288sub one { 289 eval <<'END'; 290 no warnings 'redefine'; 291 sub one { pass('sub one'); goto &two; fail('sub one tail'); } 292END 293 goto &one; 294} 295 296$::FILE = __FILE__; 297$::LINE = __LINE__ + 1; 298&one(1,2,3); 299 300{ 301 my $wherever = 'NOWHERE'; 302 eval { goto $wherever }; 303 like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@'); 304} 305 306# see if a modified @_ propagates 307{ 308 my $i; 309 package Foo; 310 sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); } 311 sub show { ::is(+@_, 5, "show $i",); } 312 sub start { push @_, 1, "foo", {}; goto &show; } 313 for (1..3) { $i = $_; start(bless([$_]), 'bar'); } 314} 315 316sub auto { 317 goto &loadit; 318} 319 320sub AUTOLOAD { $ok = 1 if "@_" eq "foo" } 321 322$ok = 0; 323auto("foo"); 324ok($ok, 'autoload'); 325 326{ 327 my $wherever = 'FINALE'; 328 goto $wherever; 329} 330fail('goto $wherever'); 331 332moretests: 333# test goto duplicated labels. 334{ 335 my $z = 0; 336 eval { 337 $z = 0; 338 for (0..1) { 339 L4: # not outer scope 340 $z += 10; 341 last; 342 } 343 goto L4 if $z == 10; 344 last; 345 }; 346 like($@, qr/Can't "goto" into the middle of a foreach loop/, 347 'catch goto middle of foreach'); 348 349 $z = 0; 350 # ambiguous label resolution (outer scope means endless loop!) 351 L1: 352 for my $x (0..1) { 353 $z += 10; 354 is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)'); 355 goto L1 unless $x; 356 $z += 10; 357 L1: 358 is($z, 10, 'prefer same scope: second'); 359 last; 360 } 361 362 $z = 0; 363 L2: 364 { 365 $z += 10; 366 is($z, 10, 'prefer this scope (block body) to outer scope (block entry)'); 367 goto L2 if $z == 10; 368 $z += 10; 369 L2: 370 is($z, 10, 'prefer this scope: second'); 371 } 372 373 374 { 375 $z = 0; 376 while (1) { 377 L3: # not inner scope 378 $z += 10; 379 last; 380 } 381 is($z, 10, 'prefer this scope to inner scope'); 382 goto L3 if $z == 10; 383 $z += 10; 384 L3: # this scope ! 385 is($z, 10, 'prefer this scope to inner scope: second'); 386 } 387 388 L4: # not outer scope 389 { 390 $z = 0; 391 while (1) { 392 L4: # not inner scope 393 $z += 1; 394 last; 395 } 396 is($z, 1, 'prefer this scope to inner,outer scopes'); 397 goto L4 if $z == 1; 398 $z += 10; 399 L4: # this scope ! 400 is($z, 1, 'prefer this scope to inner,outer scopes: second'); 401 } 402 403 { 404 my $loop = 0; 405 for my $x (0..1) { 406 L2: # without this, fails 1 (middle) out of 3 iterations 407 $z = 0; 408 L2: 409 $z += 10; 410 is($z, 10, 411 "same label, multiple times in same scope (choose 1st) $loop"); 412 goto L2 if $z == 10 and not $loop++; 413 } 414 } 415} 416 417# deep recursion with gotos eventually caused a stack reallocation 418# which messed up buggy internals that didn't expect the stack to move 419 420sub recurse1 { 421 unshift @_, "x"; 422 no warnings 'recursion'; 423 goto &recurse2; 424} 425sub recurse2 { 426 my $x = shift; 427 $_[0] ? +1 + recurse1($_[0] - 1) : 0 428} 429my $w = 0; 430$SIG{__WARN__} = sub { ++$w }; 431is(recurse1(500), 500, 'recursive goto &foo'); 432is $w, 0, 'no recursion warnings for "no warnings; goto &sub"'; 433delete $SIG{__WARN__}; 434 435# [perl #32039] Chained goto &sub drops data too early. 436 437sub a32039 { @_=("foo"); goto &b32039; } 438sub b32039 { goto &c32039; } 439sub c32039 { is($_[0], 'foo', 'chained &goto') } 440a32039(); 441 442# [perl #35214] next and redo re-entered the loop with the wrong cop, 443# causing a subsequent goto to crash 444 445{ 446 my $r = runperl( 447 stderr => 1, 448 prog => 449'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)' 450 ); 451 is($r, "ok\n", 'next and goto'); 452 453 $r = runperl( 454 stderr => 1, 455 prog => 456'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)' 457 ); 458 is($r, "ok\n", 'redo and goto'); 459} 460 461# goto &foo not allowed in evals 462 463sub null { 1 }; 464eval 'goto &null'; 465like($@, qr/Can't goto subroutine from an eval-string/, 'eval string'); 466eval { goto &null }; 467like($@, qr/Can't goto subroutine from an eval-block/, 'eval block'); 468 469# goto &foo leaves @_ alone when called from a sub 470sub returnarg { $_[0] }; 471is sub { 472 local *_ = ["ick and queasy"]; 473 goto &returnarg; 474}->("quick and easy"), "ick and queasy", 475 'goto &foo with *_{ARRAY} replaced'; 476my @__ = "\xc4\x80"; 477sub { local *_ = \@__; goto &utf8::decode }->("no thinking aloud"); 478is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}'; 479 480# And goto &foo should leave reified @_ alone 481sub { *__ = \@_; goto &null } -> ("rough and tubbery"); 482is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone'; 483 484# goto &xsub when @_ has nonexistent elements 485{ 486 no warnings "uninitialized"; 487 local @_ = (); 488 $#_++; 489 & {sub { goto &utf8::encode }}; 490 is @_, 1, 'num of elems in @_ after goto &xsub with nonexistent $_[0]'; 491 is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub'; 492} 493 494# goto &xsub when @_ itself does not exist 495undef *_; 496eval { & { sub { goto &utf8::encode } } }; 497# The main thing we are testing is that it did not crash. But make sure 498# *_{ARRAY} was untouched, too. 499is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; 500 501# goto &perlsub when @_ itself does not exist [perl #119949] 502# This was only crashing when the replaced sub call had an argument list. 503# (I.e., &{ sub { goto ... } } did not crash.) 504sub { 505 undef *_; 506 goto sub { 507 is *_{ARRAY}, undef, 'goto &perlsub when @_ does not exist'; 508 } 509}->(); 510sub { 511 local *_; 512 goto sub { 513 is *_{ARRAY}, undef, 'goto &sub when @_ does not exist (local *_)'; 514 } 515}->(); 516 517 518# [perl #36521] goto &foo in warn handler could defeat recursion avoider 519 520{ 521 my $r = runperl( 522 stderr => 1, 523 prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);' 524 ); 525 like($r, qr/bar/, "goto &foo in warn"); 526} 527 528TODO: { 529 local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes"; 530 our $global = "unmodified"; 531 if ($global) { # true but not constant-folded 532 local $global = "modified"; 533 goto ELSE; 534 } else { 535 ELSE: is($global, "unmodified"); 536 } 537} 538 539is($deprecated, 0, "following TODOed test for #43403"); 540 541#74290 542{ 543 my $x; 544 my $y; 545 F1:++$x and eval 'return if ++$y == 10; goto F1;'; 546 is($x, 10, 547 'labels outside evals can be distinguished from the start of the eval'); 548} 549 550goto wham_eth; 551die "You can't get here"; 552 553wham_eth: 1 if 0; 554ouch_eth: pass('labels persist even if their statement is optimised away'); 555 556$foo = "(0)"; 557if($foo eq $foo) { 558 goto bungo; 559} 560$foo .= "(9)"; 561bungo: 562format CHOLET = 563wellington 564. 565$foo .= "(1)"; 566SKIP: { 567 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); 568 my $cholet; 569 open(CHOLET, ">", \$cholet); 570 write CHOLET; 571 close CHOLET; 572 $foo .= "(".$cholet.")"; 573 is($foo, "(0)(1)(wellington\n)", "label before format decl"); 574} 575 576$foo = "(A)"; 577if($foo eq $foo) { 578 goto orinoco; 579} 580$foo .= "(X)"; 581orinoco: 582sub alderney { return "tobermory"; } 583$foo .= "(B)"; 584$foo .= "(".alderney().")"; 585is($foo, "(A)(B)(tobermory)", "label before sub decl"); 586 587$foo = "[0:".__PACKAGE__."]"; 588if($foo eq $foo) { 589 goto bulgaria; 590} 591$foo .= "[9]"; 592bulgaria: 593package Tomsk; 594$foo .= "[1:".__PACKAGE__."]"; 595$foo .= "[2:".__PACKAGE__."]"; 596package main; 597$foo .= "[3:".__PACKAGE__."]"; 598is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl"); 599 600$foo = "[A:".__PACKAGE__."]"; 601if($foo eq $foo) { 602 goto adelaide; 603} 604$foo .= "[Z]"; 605adelaide: 606package Cairngorm { 607 $foo .= "[B:".__PACKAGE__."]"; 608} 609$foo .= "[C:".__PACKAGE__."]"; 610is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block"); 611 612our $obidos; 613$foo = "{0}"; 614if($foo eq $foo) { 615 goto shansi; 616} 617$foo .= "{9}"; 618shansi: 619BEGIN { $obidos = "x"; } 620$foo .= "{1$obidos}"; 621is($foo, "{0}{1x}", "label before BEGIN block"); 622 623$foo = "{A:".(1.5+1.5)."}"; 624if($foo eq $foo) { 625 goto stepney; 626} 627$foo .= "{Z}"; 628stepney: 629use integer; 630$foo .= "{B:".(1.5+1.5)."}"; 631is($foo, "{A:3}{B:2}", "label before use decl"); 632 633$foo = "<0>"; 634if($foo eq $foo) { 635 goto tom; 636} 637$foo .= "<9>"; 638tom: dick: harry: 639$foo .= "<1>"; 640$foo .= "<2>"; 641is($foo, "<0><1><2>", "first of three stacked labels"); 642 643$foo = "<A>"; 644if($foo eq $foo) { 645 goto beta; 646} 647$foo .= "<Z>"; 648alpha: beta: gamma: 649$foo .= "<B>"; 650$foo .= "<C>"; 651is($foo, "<A><B><C>", "second of three stacked labels"); 652 653$foo = ",0."; 654if($foo eq $foo) { 655 goto gimel; 656} 657$foo .= ",9."; 658alef: bet: gimel: 659$foo .= ",1."; 660$foo .= ",2."; 661is($foo, ",0.,1.,2.", "third of three stacked labels"); 662 663# [perl #112316] Wrong behavior regarding labels with same prefix 664sub same_prefix_labels { 665 my $pass; 666 my $first_time = 1; 667 CATCH: { 668 if ( $first_time ) { 669 CATCHLOOP: { 670 if ( !$first_time ) { 671 return 0; 672 } 673 $first_time--; 674 goto CATCH; 675 } 676 } 677 else { 678 return 1; 679 } 680 } 681} 682 683ok( 684 same_prefix_labels(), 685 "perl 112316: goto and labels with the same prefix doesn't get mixed up" 686); 687 688eval { my $x = ""; goto $x }; 689like $@, qr/^goto must have label at /, 'goto $x where $x is empty string'; 690eval { goto "" }; 691like $@, qr/^goto must have label at /, 'goto ""'; 692eval { goto }; 693like $@, qr/^goto must have label at /, 'argless goto'; 694 695eval { my $x = "\0"; goto $x }; 696like $@, qr/^Can't find label \0 at /, 'goto $x where $x begins with \0'; 697eval { goto "\0" }; 698like $@, qr/^Can't find label \0 at /, 'goto "\0"'; 699 700sub TIESCALAR { bless [pop] } 701sub FETCH { $_[0][0] } 702tie my $t, "", sub { "cluck up porridge" }; 703is eval { sub { goto $t }->() }//$@, 'cluck up porridge', 704 'tied arg returning sub ref'; 705