t/op/goto.t

   1 #!./perl
   2
   3 # "This IS structured code.  It's just randomly structured."
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = qw(. ../lib);
   8     require "test.pl";
   9 }
  10
  11 use warnings;
  12 use strict;
  13 plan tests => 74;
  14 our $TODO;
  15
  16 my $deprecated = 0;
  17 local $SIG{__WARN__} = sub { if ($_[0] =~ m/jump into a construct/) { $deprecated++; } else { warn $_[0] } };
  18
  19 our $foo;
  20 while ($?) {
  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 }
  36 is($deprecated, 0);
  37 goto label1;
  38
  39 $foo = 3;
  40
  41 label2:
  42 is($foo, 2, 'escape while loop');
  43 is($deprecated, 0);
  44 goto label3;
  45
  46 label4:
  47 is($foo, 4, 'second escape while loop');
  48
  49 my $r = run_perl(prog => 'goto foo;', stderr => 1);
  50 like($r, qr/label/, 'cant find label');
  51
  52 my $ok = 0;
  53 sub foo {
  54     goto bar;
  55     return;
  56 bar:
  57     $ok = 1;
  58 }
  59
  60 &foo;
  61 ok($ok, 'goto in sub');
  62
  63 sub bar {
  64     my $x = 'bypass';
  65     eval "goto $x";
  66 }
  67
  68 &bar;
  69 exit;
  70
  71 FINALE:
  72 is(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.
  77 my $count = 0;
  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;
  87         is($count, 0, 'OTHER');
  88         $count++;
  89         goto THIRD;
  90     }
  91     else {
  92       THIRD:
  93         is($count, 1, 'THIRD');
  94         $count++;
  95     }
  96 }
  97 is($count, 2, 'end of loop');
  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;
 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
 111 my ($z, $y) = (0);
 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);
 116 goto FORL1;
 117
 118 # Even from within the loop?
 119 TEST19: $z = 0;
 120 FORL2: 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;
 132 eval {
 133   my $variable = 1;
 134   goto LABEL20;
 135   LABEL20: $ok = 1 if $variable;
 136 };
 137 ok($ok, 'works correctly within a try block');
 138 is($@, "", '...and $@ not set');
 139
 140 # And within an eval-string?
 141 $ok = 0;
 142 eval q{
 143   my $variable = 1;
 144   goto LABEL21;
 145   LABEL21: $ok = 1 if $variable;
 146 };
 147 ok($ok, 'works correctly within an eval string');
 148 is($@, "", '...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 }
 164 ok($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
 202 sub f1 {
 203     my $x;
 204     goto sub { $x=0; ok(1,"don't prematurely free CV\n") }
 205 }
 206 f1();
 207
 208 # bug #22181 - this used to coredump or make $x undefined, due to
 209 # erroneous popping of the inner BLOCK context
 210
 211 undef $ok;
 212 for ($count=0; $count<2; $count++) {
 213     my $x = 1;
 214     goto LABEL29;
 215     LABEL29:
 216     $ok = $x;
 217 }
 218 is($ok, 1, 'goto in for(;;) with continuation');
 219
 220 # bug #22299 - goto in require doesn't find label
 221
 222 open my $f, ">Op_goto01.pm" or die;
 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
 232 $r = runperl(prog => 'use Op_goto01; print qq[DONE\n]');
 233 is($r, "OK\nDONE\n", "goto within use-d file");
 234 unlink "Op_goto01.pm";
 235
 236 # test for [perl #24108]
 237 $ok = 1;
 238 $count = 0;
 239 sub i_return_a_label {
 240     $count++;
 241     return "returned_label";
 242 }
 243 eval { goto +i_return_a_label; };
 244 $ok = 0;
 245
 246 returned_label:
 247 is($count, 1, 'called i_return_a_label');
 248 ok($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     );
 259 is($r, "ok\n", 'avoid pad without an @_');
 260
 261 goto moretests;
 262 fail('goto moretests');
 263 exit;
 264
 265 bypass:
 266
 267 is(curr_test(), 9, 'eval "goto $x"');
 268
 269 # Test autoloading mechanism.
 270
 271 sub 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
 277 sub one {
 278     eval <<'END';
 279     no warnings 'redefine';
 280     sub one { pass('sub one'); goto &two; fail('sub one tail'); }
 281 END
 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
 305 sub auto {
 306     goto &loadit;
 307 }
 308
 309 sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
 310
 311 $ok = 0;
 312 auto("foo");
 313 ok($ok, 'autoload');
 314
 315 {
 316     my $wherever = 'FINALE';
 317     goto $wherever;
 318 }
 319 fail('goto $wherever');
 320
 321 moretests:
 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
 409 sub recurse1 {
 410     unshift @_, "x";
 411     no warnings 'recursion';
 412     goto &recurse2;
 413 }
 414 sub recurse2 {
 415     my $x = shift;
 416     $_[0] ? +1 + recurse1($_[0] - 1) : 0
 417 }
 418 is(recurse1(500), 500, 'recursive goto &foo');
 419
 420 # [perl #32039] Chained goto &sub drops data too early.
 421
 422 sub a32039 { @_=("foo"); goto &b32039; }
 423 sub b32039 { goto &c32039; }
 424 sub c32039 { is($_[0], 'foo', 'chained &goto') }
 425 a32039();
 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
 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');
 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
 465 TODO: {
 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
 476 is($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
 487 goto wham_eth;
 488 die "You can't get here";
 489
 490 wham_eth: 1 if 0;
 491 ouch_eth: pass('labels persist even if their statement is optimised away');
 492
 493 $foo = "(0)";
 494 if($foo eq $foo) {
 495     goto bungo;
 496 }
 497 $foo .= "(9)";
 498 bungo:
 499 format CHOLET =
 500 wellington
 501 .
 502 $foo .= "(1)";
 503 my $cholet;
 504 open(CHOLET, ">", \$cholet);
 505 write CHOLET;
 506 close CHOLET;
 507 $foo .= "(".$cholet.")";
 508 is($foo, "(0)(1)(wellington\n)", "label before format decl");
 509
 510 $foo = "(A)";
 511 if($foo eq $foo) {
 512     goto orinoco;
 513 }
 514 $foo .= "(X)";
 515 orinoco:
 516 sub alderney { return "tobermory"; }
 517 $foo .= "(B)";
 518 $foo .= "(".alderney().")";
 519 is($foo, "(A)(B)(tobermory)", "label before sub decl");
 520
 521 $foo = "[0:".__PACKAGE__."]";
 522 if($foo eq $foo) {
 523     goto bulgaria;
 524 }
 525 $foo .= "[9]";
 526 bulgaria:
 527 package Tomsk;
 528 $foo .= "[1:".__PACKAGE__."]";
 529 $foo .= "[2:".__PACKAGE__."]";
 530 package main;
 531 $foo .= "[3:".__PACKAGE__."]";
 532 is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl");
 533
 534 $foo = "[A:".__PACKAGE__."]";
 535 if($foo eq $foo) {
 536     goto adelaide;
 537 }
 538 $foo .= "[Z]";
 539 adelaide:
 540 package Cairngorm {
 541     $foo .= "[B:".__PACKAGE__."]";
 542 }
 543 $foo .= "[C:".__PACKAGE__."]";
 544 is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block");
 545
 546 our $obidos;
 547 $foo = "{0}";
 548 if($foo eq $foo) {
 549     goto shansi;
 550 }
 551 $foo .= "{9}";
 552 shansi:
 553 BEGIN { $obidos = "x"; }
 554 $foo .= "{1$obidos}";
 555 is($foo, "{0}{1x}", "label before BEGIN block");
 556
 557 $foo = "{A:".(1.5+1.5)."}";
 558 if($foo eq $foo) {
 559     goto stepney;
 560 }
 561 $foo .= "{Z}";
 562 stepney:
 563 use integer;
 564 $foo .= "{B:".(1.5+1.5)."}";
 565 is($foo, "{A:3}{B:2}", "label before use decl");