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"; require './charset_tools.pl';
   9 }
  10
  11 use warnings;
  12 use strict;
  13 plan tests => 94;
  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, "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 }
  36 is($deprecated, 0, "after 'while' loop");
  37 goto label1;
  38
  39 $foo = 3;
  40
  41 label2:
  42 is($foo, 2, 'escape while loop');
  43 is($deprecated, 0, "following label2");
  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, "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
 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 #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
 219 # bug #22181 - this used to coredump or make $x undefined, due to
 220 # erroneous popping of the inner BLOCK context
 221
 222 undef $ok;
 223 for ($count=0; $count<2; $count++) {
 224     my $x = 1;
 225     goto LABEL29;
 226     LABEL29:
 227     $ok = $x;
 228 }
 229 is($ok, 1, 'goto in for(;;) with continuation');
 230
 231 # bug #22299 - goto in require doesn't find label
 232
 233 open my $f, ">Op_goto01.pm" or die;
 234 print $f <<'EOT';
 235 package goto01;
 236 goto YYY;
 237 die;
 238 YYY: print "OK\n";
 239 1;
 240 EOT
 241 close $f;
 242
 243 $r = runperl(prog => 'use Op_goto01; print qq[DONE\n]');
 244 is($r, "OK\nDONE\n", "goto within use-d file");
 245 unlink_all "Op_goto01.pm";
 246
 247 # test for [perl #24108]
 248 $ok = 1;
 249 $count = 0;
 250 sub i_return_a_label {
 251     $count++;
 252     return "returned_label";
 253 }
 254 eval { goto +i_return_a_label; };
 255 $ok = 0;
 256
 257 returned_label:
 258 is($count, 1, 'called i_return_a_label');
 259 ok($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     );
 270 is($r, "ok\n", 'avoid pad without an @_');
 271
 272 goto moretests;
 273 fail('goto moretests');
 274 exit;
 275
 276 bypass:
 277
 278 is(curr_test(), 9, 'eval "goto $x"');
 279
 280 # Test autoloading mechanism.
 281
 282 sub 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
 288 sub one {
 289     eval <<'END';
 290     no warnings 'redefine';
 291     sub one { pass('sub one'); goto &two; fail('sub one tail'); }
 292 END
 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
 316 sub auto {
 317     goto &loadit;
 318 }
 319
 320 sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
 321
 322 $ok = 0;
 323 auto("foo");
 324 ok($ok, 'autoload');
 325
 326 {
 327     my $wherever = 'FINALE';
 328     goto $wherever;
 329 }
 330 fail('goto $wherever');
 331
 332 moretests:
 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
 420 sub recurse1 {
 421     unshift @_, "x";
 422     no warnings 'recursion';
 423     goto &recurse2;
 424 }
 425 sub recurse2 {
 426     my $x = shift;
 427     $_[0] ? +1 + recurse1($_[0] - 1) : 0
 428 }
 429 my $w = 0;
 430 $SIG{__WARN__} = sub { ++$w };
 431 is(recurse1(500), 500, 'recursive goto &foo');
 432 is $w, 0, 'no recursion warnings for "no warnings; goto &sub"';
 433 delete $SIG{__WARN__};
 434
 435 # [perl #32039] Chained goto &sub drops data too early.
 436
 437 sub a32039 { @_=("foo"); goto &b32039; }
 438 sub b32039 { goto &c32039; }
 439 sub c32039 { is($_[0], 'foo', 'chained &goto') }
 440 a32039();
 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
 463 sub null { 1 };
 464 eval 'goto &null';
 465 like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
 466 eval { goto &null };
 467 like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
 468
 469 # goto &foo leaves @_ alone when called from a sub
 470 sub returnarg { $_[0] };
 471 is sub {
 472     local *_ = ["ick and queasy"];
 473     goto &returnarg;
 474 }->("quick and easy"), "ick and queasy",
 475   'goto &foo with *_{ARRAY} replaced';
 476 my @__ = byte_utf8a_to_utf8n("\xc4\x80");
 477 sub { local *_ = \@__; goto &utf8::decode }->("no thinking aloud");
 478 is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}';
 479
 480 # And goto &foo should leave reified @_ alone
 481 sub { *__ = \@_;  goto &null } -> ("rough and tubbery");
 482 is ${*__}[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
 495 undef *_;
 496 eval { & { 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.
 499 is *_{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.)
 504 sub {
 505     undef *_;
 506     goto sub {
 507         is *_{ARRAY}, undef, 'goto &perlsub when @_ does not exist';
 508     }
 509 }->();
 510 sub {
 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
 528 TODO: {
 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
 539 is($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
 550 goto wham_eth;
 551 die "You can't get here";
 552
 553 wham_eth: 1 if 0;
 554 ouch_eth: pass('labels persist even if their statement is optimised away');
 555
 556 $foo = "(0)";
 557 if($foo eq $foo) {
 558     goto bungo;
 559 }
 560 $foo .= "(9)";
 561 bungo:
 562 format CHOLET =
 563 wellington
 564 .
 565 $foo .= "(1)";
 566 SKIP: {
 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)";
 577 if($foo eq $foo) {
 578     goto orinoco;
 579 }
 580 $foo .= "(X)";
 581 orinoco:
 582 sub alderney { return "tobermory"; }
 583 $foo .= "(B)";
 584 $foo .= "(".alderney().")";
 585 is($foo, "(A)(B)(tobermory)", "label before sub decl");
 586
 587 $foo = "[0:".__PACKAGE__."]";
 588 if($foo eq $foo) {
 589     goto bulgaria;
 590 }
 591 $foo .= "[9]";
 592 bulgaria:
 593 package Tomsk;
 594 $foo .= "[1:".__PACKAGE__."]";
 595 $foo .= "[2:".__PACKAGE__."]";
 596 package main;
 597 $foo .= "[3:".__PACKAGE__."]";
 598 is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl");
 599
 600 $foo = "[A:".__PACKAGE__."]";
 601 if($foo eq $foo) {
 602     goto adelaide;
 603 }
 604 $foo .= "[Z]";
 605 adelaide:
 606 package Cairngorm {
 607     $foo .= "[B:".__PACKAGE__."]";
 608 }
 609 $foo .= "[C:".__PACKAGE__."]";
 610 is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block");
 611
 612 our $obidos;
 613 $foo = "{0}";
 614 if($foo eq $foo) {
 615     goto shansi;
 616 }
 617 $foo .= "{9}";
 618 shansi:
 619 BEGIN { $obidos = "x"; }
 620 $foo .= "{1$obidos}";
 621 is($foo, "{0}{1x}", "label before BEGIN block");
 622
 623 $foo = "{A:".(1.5+1.5)."}";
 624 if($foo eq $foo) {
 625     goto stepney;
 626 }
 627 $foo .= "{Z}";
 628 stepney:
 629 use integer;
 630 $foo .= "{B:".(1.5+1.5)."}";
 631 is($foo, "{A:3}{B:2}", "label before use decl");
 632
 633 $foo = "<0>";
 634 if($foo eq $foo) {
 635     goto tom;
 636 }
 637 $foo .= "<9>";
 638 tom: dick: harry:
 639 $foo .= "<1>";
 640 $foo .= "<2>";
 641 is($foo, "<0><1><2>", "first of three stacked labels");
 642
 643 $foo = "<A>";
 644 if($foo eq $foo) {
 645     goto beta;
 646 }
 647 $foo .= "<Z>";
 648 alpha: beta: gamma:
 649 $foo .= "<B>";
 650 $foo .= "<C>";
 651 is($foo, "<A><B><C>", "second of three stacked labels");
 652
 653 $foo = ",0.";
 654 if($foo eq $foo) {
 655     goto gimel;
 656 }
 657 $foo .= ",9.";
 658 alef: bet: gimel:
 659 $foo .= ",1.";
 660 $foo .= ",2.";
 661 is($foo, ",0.,1.,2.", "third of three stacked labels");
 662
 663 # [perl #112316] Wrong behavior regarding labels with same prefix
 664 sub 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
 683 ok(
 684    same_prefix_labels(),
 685    "perl 112316: goto and labels with the same prefix doesn't get mixed up"
 686 );
 687
 688 eval { my $x = ""; goto $x };
 689 like $@, qr/^goto must have label at /, 'goto $x where $x is empty string';
 690 eval { goto "" };
 691 like $@, qr/^goto must have label at /, 'goto ""';
 692 eval { goto };
 693 like $@, qr/^goto must have label at /, 'argless goto';
 694
 695 eval { my $x = "\0"; goto $x };
 696 like $@, qr/^Can't find label \0 at /, 'goto $x where $x begins with \0';
 697 eval { goto "\0" };
 698 like $@, qr/^Can't find label \0 at /, 'goto "\0"';
 699
 700 sub TIESCALAR { bless [pop] }
 701 sub FETCH     { $_[0][0] }
 702 tie my $t, "", sub { "cluck up porridge" };
 703 is eval { sub { goto $t }->() }//$@, 'cluck up porridge',
 704   'tied arg returning sub ref';