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     require "./test.pl";
   8     set_up_inc( qw(. ../lib) );
   9         require './charset_tools.pl';
  10 }
  11
  12 use warnings;
  13 use strict;
  14 plan tests => 133;
  15 our $TODO;
  16
  17 my $deprecated = 0;
  18 local $SIG{__WARN__} = sub { if ($_[0] =~ m/jump into a construct/) { $deprecated++; } else { warn $_[0] } };
  19
  20 our $foo;
  21 while ($?) {
  22     $foo = 1;
  23   label1:
  24     is($deprecated, 1, "following label1");
  25     $deprecated = 0;
  26     $foo = 2;
  27     goto label2;
  28 } continue {
  29     $foo = 0;
  30     goto label4;
  31   label3:
  32     is($deprecated, 1, "following label3");
  33     $deprecated = 0;
  34     $foo = 4;
  35     goto label4;
  36 }
  37 is($deprecated, 0, "after 'while' loop");
  38 goto label1;
  39
  40 $foo = 3;
  41
  42 label2:
  43 is($foo, 2, 'escape while loop');
  44 is($deprecated, 0, "following label2");
  45 goto label3;
  46
  47 label4:
  48 is($foo, 4, 'second escape while loop');
  49
  50 my $r = run_perl(prog => 'goto foo;', stderr => 1);
  51 like($r, qr/label/, 'cant find label');
  52
  53 my $ok = 0;
  54 sub foo {
  55     goto bar;
  56     return;
  57 bar:
  58     $ok = 1;
  59 }
  60
  61 &foo;
  62 ok($ok, 'goto in sub');
  63
  64 sub bar {
  65     my $x = 'bypass';
  66     eval "goto $x";
  67 }
  68
  69 &bar;
  70 exit;
  71
  72 FINALE:
  73 is(curr_test(), 20, 'FINALE');
  74
  75 # does goto LABEL handle block contexts correctly?
  76 # note that this scope-hopping differs from last & next,
  77 # which always go up-scope strictly.
  78 my $count = 0;
  79 my $cond = 1;
  80 for (1) {
  81     if ($cond == 1) {
  82         $cond = 0;
  83         goto OTHER;
  84     }
  85     elsif ($cond == 0) {
  86       OTHER:
  87         $cond = 2;
  88         is($count, 0, 'OTHER');
  89         $count++;
  90         goto THIRD;
  91     }
  92     else {
  93       THIRD:
  94         is($count, 1, 'THIRD');
  95         $count++;
  96     }
  97 }
  98 is($count, 2, 'end of loop');
  99
 100 # Does goto work correctly within a for(;;) loop?
 101 #  (BUG ID 20010309.004 (#5998))
 102
 103 for(my $i=0;!$i++;) {
 104   my $x=1;
 105   goto label;
 106   label: is($x, 1, 'goto inside a for(;;) loop body from inside the body');
 107 }
 108
 109 # Does goto work correctly going *to* a for(;;) loop?
 110 #  (make sure it doesn't skip the initializer)
 111
 112 my ($z, $y) = (0);
 113 FORL1: for ($y=1; $z;) {
 114     ok($y, 'goto a for(;;) loop, from outside (does initializer)');
 115     goto TEST19}
 116 ($y,$z) = (0, 1);
 117 goto FORL1;
 118
 119 # Even from within the loop?
 120 TEST19: $z = 0;
 121 FORL2: for($y=1; 1;) {
 122   if ($z) {
 123     ok($y, 'goto a for(;;) loop, from inside (does initializer)');
 124     last;
 125   }
 126   ($y, $z) = (0, 1);
 127   goto FORL2;
 128 }
 129
 130 # Does goto work correctly within a try block?
 131 #  (BUG ID 20000313.004) - [perl #2359]
 132 $ok = 0;
 133 eval {
 134   my $variable = 1;
 135   goto LABEL20;
 136   LABEL20: $ok = 1 if $variable;
 137 };
 138 ok($ok, 'works correctly within a try block');
 139 is($@, "", '...and $@ not set');
 140
 141 # And within an eval-string?
 142 $ok = 0;
 143 eval q{
 144   my $variable = 1;
 145   goto LABEL21;
 146   LABEL21: $ok = 1 if $variable;
 147 };
 148 ok($ok, 'works correctly within an eval string');
 149 is($@, "", '...and $@ still not set');
 150
 151
 152 # Test that goto works in nested eval-string
 153 $ok = 0;
 154 {eval q{
 155   eval q{
 156     goto LABEL22;
 157   };
 158   $ok = 0;
 159   last;
 160
 161   LABEL22: $ok = 1;
 162 };
 163 $ok = 0 if $@;
 164 }
 165 ok($ok, 'works correctly in a nested eval string');
 166
 167 {
 168     my $false = 0;
 169     my $count;
 170
 171     $ok = 0;
 172     { goto A; A: $ok = 1 } continue { }
 173     ok($ok, '#20357 goto inside /{ } continue { }/ loop');
 174
 175     $ok = 0;
 176     { do { goto A; A: $ok = 1 } while $false }
 177     ok($ok, '#20154 goto inside /do { } while ()/ loop');
 178     $ok = 0;
 179     foreach(1) { goto A; A: $ok = 1 } continue { };
 180     ok($ok, 'goto inside /foreach () { } continue { }/ loop');
 181
 182     $ok = 0;
 183     sub a {
 184         A: { if ($false) { redo A; B: $ok = 1; redo A; } }
 185         goto B unless $count++;
 186     }
 187     is($deprecated, 0, "before calling sub a()");
 188     a();
 189     ok($ok, '#19061 loop label wiped away by goto');
 190     is($deprecated, 1, "after calling sub a()");
 191     $deprecated = 0;
 192
 193     $ok = 0;
 194     my $p;
 195     for ($p=1;$p && goto A;$p=0) { A: $ok = 1 }
 196     ok($ok, 'weird case of goto and for(;;) loop');
 197     is($deprecated, 1, "following goto and for(;;) loop");
 198     $deprecated = 0;
 199 }
 200
 201 # bug #9990 - don't prematurely free the CV we're &going to.
 202
 203 sub f1 {
 204     my $x;
 205     goto sub { $x=0; ok(1,"don't prematurely free CV\n") }
 206 }
 207 f1();
 208
 209 # bug #99850, which is similar - freeing the subroutine we are about to
 210 # go(in)to during a FREETMPS call should not crash perl.
 211
 212 package _99850 {
 213     sub reftype{}
 214     DESTROY { undef &reftype }
 215     eval { sub { my $guard = bless []; goto &reftype }->() };
 216 }
 217 like $@, qr/^Goto undefined subroutine &_99850::reftype at /,
 218    'goto &foo undefining &foo on sub cleanup';
 219
 220 # When croaking after discovering that the new CV you're about to goto is
 221 # undef, make sure that the old CV isn't doubly freed.
 222
 223 package Do_undef {
 224     my $count;
 225
 226     # creating a new closure here encourages any prematurely freed
 227     # CV to be reallocated
 228     sub DESTROY { undef &undef_sub; my $x = sub { $count } }
 229
 230     sub f {
 231         $count++;
 232         my $guard = bless []; # trigger DESTROY during goto
 233         *undef_sub = sub {};
 234         goto &undef_sub
 235     }
 236
 237     for (1..10) {
 238         eval { f() };
 239     }
 240     ::is($count, 10, "goto undef_sub safe");
 241 }
 242
 243 # make sure that nothing nasty happens if the old CV is freed while
 244 # goto'ing
 245
 246 package Free_cv {
 247     my $results;
 248     sub f {
 249         no warnings 'redefine';
 250         *f = sub {};
 251         goto &g;
 252     }
 253     sub g { $results = "(@_)" }
 254
 255     f(1,2,3);
 256     ::is($results, "(1 2 3)", "Free_cv");
 257 }
 258
 259
 260 # bug #22181 - this used to coredump or make $x undefined, due to
 261 # erroneous popping of the inner BLOCK context
 262
 263 undef $ok;
 264 for ($count=0; $count<2; $count++) {
 265     my $x = 1;
 266     goto LABEL29;
 267     LABEL29:
 268     $ok = $x;
 269 }
 270 is($ok, 1, 'goto in for(;;) with continuation');
 271
 272 # bug #22299 - goto in require doesn't find label
 273
 274 open my $f, ">Op_goto01.pm" or die;
 275 print $f <<'EOT';
 276 package goto01;
 277 goto YYY;
 278 die;
 279 YYY: print "OK\n";
 280 1;
 281 EOT
 282 close $f;
 283
 284 $r = runperl(prog => 'BEGIN { unshift @INC, q[.] } use Op_goto01; print qq[DONE\n]');
 285 is($r, "OK\nDONE\n", "goto within use-d file");
 286 unlink_all "Op_goto01.pm";
 287
 288 # test for [perl #24108]
 289 $ok = 1;
 290 $count = 0;
 291 sub i_return_a_label {
 292     $count++;
 293     return "returned_label";
 294 }
 295 eval { goto +i_return_a_label; };
 296 $ok = 0;
 297
 298 returned_label:
 299 is($count, 1, 'called i_return_a_label');
 300 ok($ok, 'skipped to returned_label');
 301
 302 # [perl #29708] - goto &foo could leave foo() at depth two with
 303 # @_ == PL_sv_undef, causing a coredump
 304
 305
 306 $r = runperl(
 307     prog =>
 308         'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)',
 309     stderr => 1
 310     );
 311 is($r, "ok\n", 'avoid pad without an @_');
 312
 313 goto moretests;
 314 fail('goto moretests');
 315 exit;
 316
 317 bypass:
 318
 319 is(curr_test(), 9, 'eval "goto $x"');
 320
 321 # Test autoloading mechanism.
 322
 323 sub two {
 324     my ($pack, $file, $line) = caller;  # Should indicate original call stats.
 325     is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE",
 326         'autoloading mechanism.');
 327 }
 328
 329 sub one {
 330     eval <<'END';
 331     no warnings 'redefine';
 332     sub one { pass('sub one'); goto &two; fail('sub one tail'); }
 333 END
 334     goto &one;
 335 }
 336
 337 $::FILE = __FILE__;
 338 $::LINE = __LINE__ + 1;
 339 &one(1,2,3);
 340
 341 {
 342     my $wherever = 'NOWHERE';
 343     eval { goto $wherever };
 344     like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@');
 345 }
 346
 347 # see if a modified @_ propagates
 348 {
 349   my $i;
 350   package Foo;
 351   sub DESTROY   { my $s = shift; ::is($s->[0], $i, "destroy $i"); }
 352   sub show      { ::is(+@_, 5, "show $i",); }
 353   sub start     { push @_, 1, "foo", {}; goto &show; }
 354   for (1..3)    { $i = $_; start(bless([$_]), 'bar'); }
 355 }
 356
 357 sub auto {
 358     goto &loadit;
 359 }
 360
 361 sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
 362
 363 $ok = 0;
 364 auto("foo");
 365 ok($ok, 'autoload');
 366
 367 {
 368     my $wherever = 'FINALE';
 369     goto $wherever;
 370 }
 371 fail('goto $wherever');
 372
 373 moretests:
 374 # test goto duplicated labels.
 375 {
 376     my $z = 0;
 377     eval {
 378         $z = 0;
 379         for (0..1) {
 380           L4: # not outer scope
 381             $z += 10;
 382             last;
 383         }
 384         goto L4 if $z == 10;
 385         last;
 386     };
 387     like($@, qr/Can't "goto" into the middle of a foreach loop/,
 388             'catch goto middle of foreach');
 389
 390     $z = 0;
 391     # ambiguous label resolution (outer scope means endless loop!)
 392   L1:
 393     for my $x (0..1) {
 394         $z += 10;
 395         is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)');
 396         goto L1 unless $x;
 397         $z += 10;
 398       L1:
 399         is($z, 10, 'prefer same scope: second');
 400         last;
 401     }
 402
 403     $z = 0;
 404   L2:
 405     {
 406         $z += 10;
 407         is($z, 10, 'prefer this scope (block body) to outer scope (block entry)');
 408         goto L2 if $z == 10;
 409         $z += 10;
 410       L2:
 411         is($z, 10, 'prefer this scope: second');
 412     }
 413
 414
 415     {
 416         $z = 0;
 417         while (1) {
 418           L3: # not inner scope
 419             $z += 10;
 420             last;
 421         }
 422         is($z, 10, 'prefer this scope to inner scope');
 423         goto L3 if $z == 10;
 424         $z += 10;
 425       L3: # this scope !
 426         is($z, 10, 'prefer this scope to inner scope: second');
 427     }
 428
 429   L4: # not outer scope
 430     {
 431         $z = 0;
 432         while (1) {
 433           L4: # not inner scope
 434             $z += 1;
 435             last;
 436         }
 437         is($z, 1, 'prefer this scope to inner,outer scopes');
 438         goto L4 if $z == 1;
 439         $z += 10;
 440       L4: # this scope !
 441         is($z, 1, 'prefer this scope to inner,outer scopes: second');
 442     }
 443
 444     {
 445         my $loop = 0;
 446         for my $x (0..1) {
 447           L2: # without this, fails 1 (middle) out of 3 iterations
 448             $z = 0;
 449           L2:
 450             $z += 10;
 451             is($z, 10,
 452                 "same label, multiple times in same scope (choose 1st) $loop");
 453             goto L2 if $z == 10 and not $loop++;
 454         }
 455     }
 456 }
 457
 458 # This bug was introduced in Aug 2010 by commit ac56e7de46621c6f
 459 # Peephole optimise adjacent pairs of nextstate ops.
 460 # and fixed in Oct 2014 by commit f5b5c2a37af87535
 461 # Simplify double-nextstate optimisation
 462
 463 # The bug manifests as a warning
 464 # Use of "goto" to jump into a construct is deprecated at t/op/goto.t line 442.
 465 # and $out is undefined. Devel::Peek reveals that the lexical in the pad has
 466 # been reset to undef. I infer that pp_goto thinks that it's leaving one scope
 467 # and entering another, but I don't know *why* it thinks that. Whilst this bug
 468 # has been fixed by Father C, because I don't understand why it happened, I am
 469 # not confident that other related bugs remain (or have always existed).
 470
 471 sub DEBUG_TIME() {
 472     0;
 473 }
 474
 475 {
 476     if (DEBUG_TIME) {
 477     }
 478
 479     {
 480         my $out = "";
 481         $out .= 'perl rules';
 482         goto no_list;
 483     no_list:
 484         is($out, 'perl rules', '$out has not been erroneously reset to undef');
 485     };
 486 }
 487
 488 is($deprecated, 0, 'no warning was emmitted');
 489
 490 # deep recursion with gotos eventually caused a stack reallocation
 491 # which messed up buggy internals that didn't expect the stack to move
 492
 493 sub recurse1 {
 494     unshift @_, "x";
 495     no warnings 'recursion';
 496     goto &recurse2;
 497 }
 498 sub recurse2 {
 499     my $x = shift;
 500     $_[0] ? +1 + recurse1($_[0] - 1) : 0
 501 }
 502 my $w = 0;
 503 $SIG{__WARN__} = sub { ++$w };
 504 is(recurse1(500), 500, 'recursive goto &foo');
 505 is $w, 0, 'no recursion warnings for "no warnings; goto &sub"';
 506 delete $SIG{__WARN__};
 507
 508 # [perl #32039] Chained goto &sub drops data too early.
 509
 510 sub a32039 { @_=("foo"); goto &b32039; }
 511 sub b32039 { goto &c32039; }
 512 sub c32039 { is($_[0], 'foo', 'chained &goto') }
 513 a32039();
 514
 515 # [perl #35214] next and redo re-entered the loop with the wrong cop,
 516 # causing a subsequent goto to crash
 517
 518 {
 519     my $r = runperl(
 520                 stderr => 1,
 521                 prog =>
 522 'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)'
 523     );
 524     is($r, "ok\n", 'next and goto');
 525
 526     $r = runperl(
 527                 stderr => 1,
 528                 prog =>
 529 'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)'
 530     );
 531     is($r, "ok\n", 'redo and goto');
 532 }
 533
 534 # goto &foo not allowed in evals
 535
 536 sub null { 1 };
 537 eval 'goto &null';
 538 like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
 539 eval { goto &null };
 540 like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
 541
 542 # goto &foo leaves @_ alone when called from a sub
 543 sub returnarg { $_[0] };
 544 is sub {
 545     local *_ = ["ick and queasy"];
 546     goto &returnarg;
 547 }->("quick and easy"), "ick and queasy",
 548   'goto &foo with *_{ARRAY} replaced';
 549 my @__ = byte_utf8a_to_utf8n("\xc4\x80");
 550 sub { local *_ = \@__; goto &utf8::decode }->("no thinking aloud");
 551 is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}';
 552
 553 # And goto &foo should leave reified @_ alone
 554 sub { *__ = \@_;  goto &null } -> ("rough and tubbery");
 555 is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone';
 556
 557 # goto &xsub when @_ has nonexistent elements
 558 {
 559     no warnings "uninitialized";
 560     local @_ = ();
 561     $#_++;
 562     & {sub { goto &utf8::encode }};
 563     is @_, 1, 'num of elems in @_ after goto &xsub with nonexistent $_[0]';
 564     is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub';
 565 }
 566
 567 # goto &xsub when @_ itself does not exist
 568 undef *_;
 569 eval { & { sub { goto &utf8::encode } } };
 570 # The main thing we are testing is that it did not crash.  But make sure
 571 # *_{ARRAY} was untouched, too.
 572 is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
 573
 574 # goto &perlsub when @_ itself does not exist [perl #119949]
 575 # This was only crashing when the replaced sub call had an argument list.
 576 # (I.e., &{ sub { goto ... } } did not crash.)
 577 sub {
 578     undef *_;
 579     goto sub {
 580         is *_{ARRAY}, undef, 'goto &perlsub when @_ does not exist';
 581     }
 582 }->();
 583 sub {
 584     local *_;
 585     goto sub {
 586         is *_{ARRAY}, undef, 'goto &sub when @_ does not exist (local *_)';
 587     }
 588 }->();
 589
 590
 591 # [perl #36521] goto &foo in warn handler could defeat recursion avoider
 592
 593 {
 594     my $r = runperl(
 595                 stderr => 1,
 596                 prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
 597     );
 598     like($r, qr/bar/, "goto &foo in warn");
 599 }
 600
 601 TODO: {
 602     local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes";
 603     our $global = "unmodified";
 604     if ($global) { # true but not constant-folded
 605          local $global = "modified";
 606          goto ELSE;
 607     } else {
 608          ELSE: is($global, "unmodified");
 609     }
 610 }
 611
 612 is($deprecated, 0, "following TODOed test for #43403");
 613
 614 #74290
 615 {
 616     my $x;
 617     my $y;
 618     F1:++$x and eval 'return if ++$y == 10; goto F1;';
 619     is($x, 10,
 620        'labels outside evals can be distinguished from the start of the eval');
 621 }
 622
 623 goto wham_eth;
 624 die "You can't get here";
 625
 626 wham_eth: 1 if 0;
 627 ouch_eth: pass('labels persist even if their statement is optimised away');
 628
 629 $foo = "(0)";
 630 if($foo eq $foo) {
 631     goto bungo;
 632 }
 633 $foo .= "(9)";
 634 bungo:
 635 format CHOLET =
 636 wellington
 637 .
 638 $foo .= "(1)";
 639 SKIP: {
 640     skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
 641     my $cholet;
 642     open(CHOLET, ">", \$cholet);
 643     write CHOLET;
 644     close CHOLET;
 645     $foo .= "(".$cholet.")";
 646     is($foo, "(0)(1)(wellington\n)", "label before format decl");
 647 }
 648
 649 $foo = "(A)";
 650 if($foo eq $foo) {
 651     goto orinoco;
 652 }
 653 $foo .= "(X)";
 654 orinoco:
 655 sub alderney { return "tobermory"; }
 656 $foo .= "(B)";
 657 $foo .= "(".alderney().")";
 658 is($foo, "(A)(B)(tobermory)", "label before sub decl");
 659
 660 $foo = "[0:".__PACKAGE__."]";
 661 if($foo eq $foo) {
 662     goto bulgaria;
 663 }
 664 $foo .= "[9]";
 665 bulgaria:
 666 package Tomsk;
 667 $foo .= "[1:".__PACKAGE__."]";
 668 $foo .= "[2:".__PACKAGE__."]";
 669 package main;
 670 $foo .= "[3:".__PACKAGE__."]";
 671 is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl");
 672
 673 $foo = "[A:".__PACKAGE__."]";
 674 if($foo eq $foo) {
 675     goto adelaide;
 676 }
 677 $foo .= "[Z]";
 678 adelaide:
 679 package Cairngorm {
 680     $foo .= "[B:".__PACKAGE__."]";
 681 }
 682 $foo .= "[C:".__PACKAGE__."]";
 683 is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block");
 684
 685 our $obidos;
 686 $foo = "{0}";
 687 if($foo eq $foo) {
 688     goto shansi;
 689 }
 690 $foo .= "{9}";
 691 shansi:
 692 BEGIN { $obidos = "x"; }
 693 $foo .= "{1$obidos}";
 694 is($foo, "{0}{1x}", "label before BEGIN block");
 695
 696 $foo = "{A:".(1.5+1.5)."}";
 697 if($foo eq $foo) {
 698     goto stepney;
 699 }
 700 $foo .= "{Z}";
 701 stepney:
 702 use integer;
 703 $foo .= "{B:".(1.5+1.5)."}";
 704 is($foo, "{A:3}{B:2}", "label before use decl");
 705
 706 $foo = "<0>";
 707 if($foo eq $foo) {
 708     goto tom;
 709 }
 710 $foo .= "<9>";
 711 tom: dick: harry:
 712 $foo .= "<1>";
 713 $foo .= "<2>";
 714 is($foo, "<0><1><2>", "first of three stacked labels");
 715
 716 $foo = "<A>";
 717 if($foo eq $foo) {
 718     goto beta;
 719 }
 720 $foo .= "<Z>";
 721 alpha: beta: gamma:
 722 $foo .= "<B>";
 723 $foo .= "<C>";
 724 is($foo, "<A><B><C>", "second of three stacked labels");
 725
 726 $foo = ",0.";
 727 if($foo eq $foo) {
 728     goto gimel;
 729 }
 730 $foo .= ",9.";
 731 alef: bet: gimel:
 732 $foo .= ",1.";
 733 $foo .= ",2.";
 734 is($foo, ",0.,1.,2.", "third of three stacked labels");
 735
 736 # [perl #112316] Wrong behavior regarding labels with same prefix
 737 sub same_prefix_labels {
 738     my $pass;
 739     my $first_time = 1;
 740     CATCH: {
 741         if ( $first_time ) {
 742             CATCHLOOP: {
 743                 if ( !$first_time ) {
 744                   return 0;
 745                 }
 746                 $first_time--;
 747                 goto CATCH;
 748             }
 749         }
 750         else {
 751             return 1;
 752         }
 753     }
 754 }
 755
 756 ok(
 757    same_prefix_labels(),
 758    "perl 112316: goto and labels with the same prefix doesn't get mixed up"
 759 );
 760
 761 eval { my $x = ""; goto $x };
 762 like $@, qr/^goto must have label at /, 'goto $x where $x is empty string';
 763 eval { goto "" };
 764 like $@, qr/^goto must have label at /, 'goto ""';
 765 eval { goto };
 766 like $@, qr/^goto must have label at /, 'argless goto';
 767
 768 eval { my $x = "\0"; goto $x };
 769 like $@, qr/^Can't find label \0 at /, 'goto $x where $x begins with \0';
 770 eval { goto "\0" };
 771 like $@, qr/^Can't find label \0 at /, 'goto "\0"';
 772
 773 sub TIESCALAR { bless [pop] }
 774 sub FETCH     { $_[0][0] }
 775 tie my $t, "", sub { "cluck up porridge" };
 776 is eval { sub { goto $t }->() }//$@, 'cluck up porridge',
 777   'tied arg returning sub ref';
 778
 779 TODO: {
 780   local $::TODO = 'RT #45091: goto in CORE::GLOBAL::exit unsupported';
 781   fresh_perl_is(<<'EOC', "before\ndie handler\n", {stderr => 1}, 'RT #45091: goto in CORE::GLOBAL::EXIT');
 782   BEGIN {
 783     *CORE::GLOBAL::exit = sub {
 784       goto FASTCGI_NEXT_REQUEST;
 785     };
 786   }
 787   while (1) {
 788     eval { that_cgi_script() };
 789     FASTCGI_NEXT_REQUEST:
 790     last;
 791   }
 792
 793   sub that_cgi_script {
 794     local $SIG{__DIE__} = sub { print "die handler\n"; exit; print "exit failed?\n"; };
 795     print "before\n";
 796     eval { buggy_code() };
 797     print "after\n";
 798   }
 799   sub buggy_code {
 800     die "error!";
 801     print "after die\n";
 802   }
 803 EOC
 804 }
 805
 806 sub revnumcmp ($$) {
 807   goto FOO;
 808   die;
 809   FOO:
 810   return $_[1] <=> $_[0];
 811 }
 812 is eval { join(":", sort revnumcmp (9,5,1,3,7)) }, "9:7:5:3:1",
 813   "can goto at top level of multicalled sub";
 814
 815 # A bit strange, but goingto these constructs should not cause any stack
 816 # problems.  Let’s test them to make sure that is the case.
 817 no warnings 'deprecated';
 818 is \sub :lvalue { goto d; ${*{scalar(do { d: \*foo })}} }->(), \$foo,
 819    'goto into rv2sv, rv2gv and scalar';
 820 is sub { goto e; $#{; do { e: \@_ } } }->(1..7), 6,
 821    'goto into $#{...}';
 822 is sub { goto f; prototype \&{; do { f: sub ($) {} } } }->(), '$',
 823    'goto into srefgen, prototype and rv2cv';
 824 is sub { goto g; ref do { g: [] } }->(), 'ARRAY',
 825    'goto into ref';
 826 is sub { goto j; defined undef ${; do { j: \(my $foo = "foo") } } }->(),'',
 827    'goto into defined and undef';
 828 is sub { goto k; study ++${; do { k: \(my $foo = "foo") } } }->(),'1',
 829    'goto into study and preincrement';
 830 is sub { goto l; ~-!${; do { l: \(my $foo = 0) } }++ }->(),~-1,
 831    'goto into complement, not, negation and postincrement';
 832 like sub { goto n; sin cos exp log sqrt do { n: 1 } }->(),qr/^0\.51439/,
 833    'goto into sin, cos, exp, log, and sqrt';
 834 ok sub { goto o; srand do { o: 0 } }->(),
 835    'goto into srand';
 836 cmp_ok sub { goto p; rand do { p: 1 } }->(), '<', 1,
 837    'goto into rand';
 838 is sub { goto r; chr ord length int hex oct abs do { r: -15.5 } }->(), 2,
 839    'goto into chr, ord, length, int, hex, oct and abs';
 840 is sub { goto t; ucfirst lcfirst uc lc do { t: "q" } }->(), 'Q',
 841    'goto into ucfirst, lcfirst, uc and lc';
 842 { no strict;
 843   is sub { goto u; \@{; quotemeta do { u: "." } } }->(), \@{'\.'},
 844    'goto into rv2av and quotemeta';
 845 }
 846 is join(" ",sub { goto v; %{; do { v: +{1..2} } } }->()), '1 2',
 847    'goto into rv2hv';
 848 is join(" ",sub { goto w; $_ || do { w: "w" } }->()), 'w',
 849    'goto into rhs of or';
 850 is join(" ",sub { goto x; $_ && do { x: "w" } }->()), 'w',
 851    'goto into rhs of and';
 852 is join(" ",sub { goto z; $_ ? do { z: "w" } : 0 }->()), 'w',
 853    'goto into first leg of ?:';
 854 is join(" ",sub { goto z; $_ ? 0 : do { z: "w" } }->()), 'w',
 855    'goto into second leg of ?:';
 856 is sub { goto z; caller do { z: 0 } }->(), 'main',
 857    'goto into caller';
 858 is sub { goto z; exit do { z: return "foo" } }->(), 'foo',
 859    'goto into exit';
 860 is sub { goto z; eval do { z: "'foo'" } }->(), 'foo',
 861    'goto into eval';
 862 TODO: {
 863     local $TODO = "glob() does not currently return a list on VMS" if $^O eq 'VMS';
 864     is join(",",sub { goto z; glob do { z: "foo bar" } }->()), 'foo,bar',
 865        'goto into glob';
 866 }
 867 # [perl #132799]
 868 # Erroneous inward goto warning, followed by crash.
 869 # The eval must be in an assignment.
 870 sub _routine {
 871     my $e = eval {
 872         goto L2;
 873       L2:
 874     }
 875 }
 876 _routine();
 877 pass("bug 132799");
 878
 879 # [perl #132854]
 880 # Goto the *first* parameter of a binary expression, which is harmless.
 881 eval {
 882     goto __GEN_2;
 883     my $sent = do {
 884         __GEN_2:
 885     };
 886 };
 887 is $@,'', 'goto the first parameter of a binary expression [perl #132854]';
 888
 889 # v5.31.3-198-gd2cd363728 broke this. goto &XS_sub  wasn't restoring
 890 # cx->blk_sub.old_cxsubix. Would panic in pp_return
 891
 892 {
 893     # isa is an XS sub
 894     sub g198 {  goto &UNIVERSAL::isa }
 895
 896     sub f198 {
 897         g198([], 1 );
 898         {
 899             return 1;
 900         }
 901     }
 902     eval { f198(); };
 903     is $@, "", "v5.31.3-198-gd2cd363728";
 904 }
 905
 906 # GH #19188
 907 #
 908 # 'goto &xs_sub' should provide the correct caller context to an XS sub
 909
 910 SKIP:
 911 {
 912     skip "No XS::APItest in miniperl", 6 if is_miniperl();
 913
 914     require XS::APItest;
 915
 916     sub f_19188 { goto &XS::APItest::gimme }
 917     sub g_19188{ f_19188(); }
 918     my ($s, @a);
 919
 920     f_19188();
 921     is ($XS::APItest::GIMME_V, 1, 'xs_goto void (#19188)');
 922
 923     $s = f_19188();
 924     is ($XS::APItest::GIMME_V, 2, 'xs_goto scalar (#19188)');
 925
 926     @a = f_19188();
 927     is ($XS::APItest::GIMME_V, 3, 'xs_goto list (#19188)');
 928
 929     g_19188();
 930     is ($XS::APItest::GIMME_V, 1, 'xs_goto indirect void (#19188)');
 931
 932     $s = g_19188();
 933     is ($XS::APItest::GIMME_V, 2, 'xs_goto indirect scalar (#19188)');
 934
 935     @a = g_19188();
 936     is ($XS::APItest::GIMME_V, 3, 'xs_goto indirect list (#19188)');
 937 }
 938
 939 # GH #19936 segfault on goto &xs_sub when calling sub is replaced
 940 SKIP:
 941 {
 942     skip "No XS::APItest in miniperl", 2 if is_miniperl();
 943
 944     # utf8::is_utf8() is just an example of an XS sub
 945     sub foo_19936 { *foo_19936 = {}; goto &utf8::is_utf8 }
 946     ok(foo_19936("\x{100}"), "GH #19936 utf8 XS call");
 947
 948     # the gimme XS function accesses PL_op, which was null before the fix
 949     sub bar_19936 { *bar_19936 = {}; goto &XS::APItest::gimme }
 950     my @a = bar_19936();
 951     is($XS::APItest::GIMME_V, 3, "GH #19936 gimme XS call");
 952 }