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"; require './charset_tools.pl';
   8     set_up_inc( qw(. ../lib) );
   9 }
  10
  11 use warnings;
  12 use strict;
  13 plan tests => 99;
  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 (#5998))
 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 # When croaking after discovering that the new CV you're about to goto is
 220 # undef, make sure that the old CV isn't doubly freed.
 221
 222 package Do_undef {
 223     my $count;
 224
 225     # creating a new closure here encourages any prematurely freed
 226     # CV to be reallocated
 227     sub DESTROY { undef &undef_sub; my $x = sub { $count } }
 228
 229     sub f {
 230         $count++;
 231         my $guard = bless []; # trigger DESTROY during goto
 232         *undef_sub = sub {};
 233         goto &undef_sub
 234     }
 235
 236     for (1..10) {
 237         eval { f() };
 238     }
 239     ::is($count, 10, "goto undef_sub safe");
 240 }
 241
 242 # make sure that nothing nasty happens if the old CV is freed while
 243 # goto'ing
 244
 245 package Free_cv {
 246     my $results;
 247     sub f {
 248         no warnings 'redefine';
 249         *f = sub {};
 250         goto &g;
 251     }
 252     sub g { $results = "(@_)" }
 253
 254     f(1,2,3);
 255     ::is($results, "(1 2 3)", "Free_cv");
 256 }
 257
 258
 259 # bug #22181 - this used to coredump or make $x undefined, due to
 260 # erroneous popping of the inner BLOCK context
 261
 262 undef $ok;
 263 for ($count=0; $count<2; $count++) {
 264     my $x = 1;
 265     goto LABEL29;
 266     LABEL29:
 267     $ok = $x;
 268 }
 269 is($ok, 1, 'goto in for(;;) with continuation');
 270
 271 # bug #22299 - goto in require doesn't find label
 272
 273 open my $f, ">Op_goto01.pm" or die;
 274 print $f <<'EOT';
 275 package goto01;
 276 goto YYY;
 277 die;
 278 YYY: print "OK\n";
 279 1;
 280 EOT
 281 close $f;
 282
 283 $r = runperl(prog => 'BEGIN { unshift @INC, q[.] } use Op_goto01; print qq[DONE\n]');
 284 is($r, "OK\nDONE\n", "goto within use-d file");
 285 unlink_all "Op_goto01.pm";
 286
 287 # test for [perl #24108]
 288 $ok = 1;
 289 $count = 0;
 290 sub i_return_a_label {
 291     $count++;
 292     return "returned_label";
 293 }
 294 eval { goto +i_return_a_label; };
 295 $ok = 0;
 296
 297 returned_label:
 298 is($count, 1, 'called i_return_a_label');
 299 ok($ok, 'skipped to returned_label');
 300
 301 # [perl #29708] - goto &foo could leave foo() at depth two with
 302 # @_ == PL_sv_undef, causing a coredump
 303
 304
 305 $r = runperl(
 306     prog =>
 307         'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)',
 308     stderr => 1
 309     );
 310 is($r, "ok\n", 'avoid pad without an @_');
 311
 312 goto moretests;
 313 fail('goto moretests');
 314 exit;
 315
 316 bypass:
 317
 318 is(curr_test(), 9, 'eval "goto $x"');
 319
 320 # Test autoloading mechanism.
 321
 322 sub two {
 323     my ($pack, $file, $line) = caller;  # Should indicate original call stats.
 324     is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE",
 325         'autoloading mechanism.');
 326 }
 327
 328 sub one {
 329     eval <<'END';
 330     no warnings 'redefine';
 331     sub one { pass('sub one'); goto &two; fail('sub one tail'); }
 332 END
 333     goto &one;
 334 }
 335
 336 $::FILE = __FILE__;
 337 $::LINE = __LINE__ + 1;
 338 &one(1,2,3);
 339
 340 {
 341     my $wherever = 'NOWHERE';
 342     eval { goto $wherever };
 343     like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@');
 344 }
 345
 346 # see if a modified @_ propagates
 347 {
 348   my $i;
 349   package Foo;
 350   sub DESTROY   { my $s = shift; ::is($s->[0], $i, "destroy $i"); }
 351   sub show      { ::is(+@_, 5, "show $i",); }
 352   sub start     { push @_, 1, "foo", {}; goto &show; }
 353   for (1..3)    { $i = $_; start(bless([$_]), 'bar'); }
 354 }
 355
 356 sub auto {
 357     goto &loadit;
 358 }
 359
 360 sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
 361
 362 $ok = 0;
 363 auto("foo");
 364 ok($ok, 'autoload');
 365
 366 {
 367     my $wherever = 'FINALE';
 368     goto $wherever;
 369 }
 370 fail('goto $wherever');
 371
 372 moretests:
 373 # test goto duplicated labels.
 374 {
 375     my $z = 0;
 376     eval {
 377         $z = 0;
 378         for (0..1) {
 379           L4: # not outer scope
 380             $z += 10;
 381             last;
 382         }
 383         goto L4 if $z == 10;
 384         last;
 385     };
 386     like($@, qr/Can't "goto" into the middle of a foreach loop/,
 387             'catch goto middle of foreach');
 388
 389     $z = 0;
 390     # ambiguous label resolution (outer scope means endless loop!)
 391   L1:
 392     for my $x (0..1) {
 393         $z += 10;
 394         is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)');
 395         goto L1 unless $x;
 396         $z += 10;
 397       L1:
 398         is($z, 10, 'prefer same scope: second');
 399         last;
 400     }
 401
 402     $z = 0;
 403   L2:
 404     {
 405         $z += 10;
 406         is($z, 10, 'prefer this scope (block body) to outer scope (block entry)');
 407         goto L2 if $z == 10;
 408         $z += 10;
 409       L2:
 410         is($z, 10, 'prefer this scope: second');
 411     }
 412
 413
 414     {
 415         $z = 0;
 416         while (1) {
 417           L3: # not inner scope
 418             $z += 10;
 419             last;
 420         }
 421         is($z, 10, 'prefer this scope to inner scope');
 422         goto L3 if $z == 10;
 423         $z += 10;
 424       L3: # this scope !
 425         is($z, 10, 'prefer this scope to inner scope: second');
 426     }
 427
 428   L4: # not outer scope
 429     {
 430         $z = 0;
 431         while (1) {
 432           L4: # not inner scope
 433             $z += 1;
 434             last;
 435         }
 436         is($z, 1, 'prefer this scope to inner,outer scopes');
 437         goto L4 if $z == 1;
 438         $z += 10;
 439       L4: # this scope !
 440         is($z, 1, 'prefer this scope to inner,outer scopes: second');
 441     }
 442
 443     {
 444         my $loop = 0;
 445         for my $x (0..1) {
 446           L2: # without this, fails 1 (middle) out of 3 iterations
 447             $z = 0;
 448           L2:
 449             $z += 10;
 450             is($z, 10,
 451                 "same label, multiple times in same scope (choose 1st) $loop");
 452             goto L2 if $z == 10 and not $loop++;
 453         }
 454     }
 455 }
 456
 457 # This bug was introduced in Aug 2010 by commit ac56e7de46621c6f
 458 # Peephole optimise adjacent pairs of nextstate ops.
 459 # and fixed in Oct 2014 by commit f5b5c2a37af87535
 460 # Simplify double-nextstate optimisation
 461
 462 # The bug manifests as a warning
 463 # Use of "goto" to jump into a construct is deprecated at t/op/goto.t line 442.
 464 # and $out is undefined. Devel::Peek reveals that the lexical in the pad has
 465 # been reset to undef. I infer that pp_goto thinks that it's leaving one scope
 466 # and entering another, but I don't know *why* it thinks that. Whilst this bug
 467 # has been fixed by Father C, because I don't understand why it happened, I am
 468 # not confident that other related bugs remain (or have always existed).
 469
 470 sub DEBUG_TIME() {
 471     0;
 472 }
 473
 474 {
 475     if (DEBUG_TIME) {
 476     }
 477
 478     {
 479         my $out = "";
 480         $out .= 'perl rules';
 481         goto no_list;
 482     no_list:
 483         is($out, 'perl rules', '$out has not been erroneously reset to undef');
 484     };
 485 }
 486
 487 is($deprecated, 0, 'no warning was emmitted');
 488
 489 # deep recursion with gotos eventually caused a stack reallocation
 490 # which messed up buggy internals that didn't expect the stack to move
 491
 492 sub recurse1 {
 493     unshift @_, "x";
 494     no warnings 'recursion';
 495     goto &recurse2;
 496 }
 497 sub recurse2 {
 498     my $x = shift;
 499     $_[0] ? +1 + recurse1($_[0] - 1) : 0
 500 }
 501 my $w = 0;
 502 $SIG{__WARN__} = sub { ++$w };
 503 is(recurse1(500), 500, 'recursive goto &foo');
 504 is $w, 0, 'no recursion warnings for "no warnings; goto &sub"';
 505 delete $SIG{__WARN__};
 506
 507 # [perl #32039] Chained goto &sub drops data too early.
 508
 509 sub a32039 { @_=("foo"); goto &b32039; }
 510 sub b32039 { goto &c32039; }
 511 sub c32039 { is($_[0], 'foo', 'chained &goto') }
 512 a32039();
 513
 514 # [perl #35214] next and redo re-entered the loop with the wrong cop,
 515 # causing a subsequent goto to crash
 516
 517 {
 518     my $r = runperl(
 519                 stderr => 1,
 520                 prog =>
 521 'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)'
 522     );
 523     is($r, "ok\n", 'next and goto');
 524
 525     $r = runperl(
 526                 stderr => 1,
 527                 prog =>
 528 'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)'
 529     );
 530     is($r, "ok\n", 'redo and goto');
 531 }
 532
 533 # goto &foo not allowed in evals
 534
 535 sub null { 1 };
 536 eval 'goto &null';
 537 like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
 538 eval { goto &null };
 539 like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
 540
 541 # goto &foo leaves @_ alone when called from a sub
 542 sub returnarg { $_[0] };
 543 is sub {
 544     local *_ = ["ick and queasy"];
 545     goto &returnarg;
 546 }->("quick and easy"), "ick and queasy",
 547   'goto &foo with *_{ARRAY} replaced';
 548 my @__ = byte_utf8a_to_utf8n("\xc4\x80");
 549 sub { local *_ = \@__; goto &utf8::decode }->("no thinking aloud");
 550 is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}';
 551
 552 # And goto &foo should leave reified @_ alone
 553 sub { *__ = \@_;  goto &null } -> ("rough and tubbery");
 554 is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone';
 555
 556 # goto &xsub when @_ has nonexistent elements
 557 {
 558     no warnings "uninitialized";
 559     local @_ = ();
 560     $#_++;
 561     & {sub { goto &utf8::encode }};
 562     is @_, 1, 'num of elems in @_ after goto &xsub with nonexistent $_[0]';
 563     is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub';
 564 }
 565
 566 # goto &xsub when @_ itself does not exist
 567 undef *_;
 568 eval { & { sub { goto &utf8::encode } } };
 569 # The main thing we are testing is that it did not crash.  But make sure
 570 # *_{ARRAY} was untouched, too.
 571 is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
 572
 573 # goto &perlsub when @_ itself does not exist [perl #119949]
 574 # This was only crashing when the replaced sub call had an argument list.
 575 # (I.e., &{ sub { goto ... } } did not crash.)
 576 sub {
 577     undef *_;
 578     goto sub {
 579         is *_{ARRAY}, undef, 'goto &perlsub when @_ does not exist';
 580     }
 581 }->();
 582 sub {
 583     local *_;
 584     goto sub {
 585         is *_{ARRAY}, undef, 'goto &sub when @_ does not exist (local *_)';
 586     }
 587 }->();
 588
 589
 590 # [perl #36521] goto &foo in warn handler could defeat recursion avoider
 591
 592 {
 593     my $r = runperl(
 594                 stderr => 1,
 595                 prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
 596     );
 597     like($r, qr/bar/, "goto &foo in warn");
 598 }
 599
 600 TODO: {
 601     local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes";
 602     our $global = "unmodified";
 603     if ($global) { # true but not constant-folded
 604          local $global = "modified";
 605          goto ELSE;
 606     } else {
 607          ELSE: is($global, "unmodified");
 608     }
 609 }
 610
 611 is($deprecated, 0, "following TODOed test for #43403");
 612
 613 #74290
 614 {
 615     my $x;
 616     my $y;
 617     F1:++$x and eval 'return if ++$y == 10; goto F1;';
 618     is($x, 10,
 619        'labels outside evals can be distinguished from the start of the eval');
 620 }
 621
 622 goto wham_eth;
 623 die "You can't get here";
 624
 625 wham_eth: 1 if 0;
 626 ouch_eth: pass('labels persist even if their statement is optimised away');
 627
 628 $foo = "(0)";
 629 if($foo eq $foo) {
 630     goto bungo;
 631 }
 632 $foo .= "(9)";
 633 bungo:
 634 format CHOLET =
 635 wellington
 636 .
 637 $foo .= "(1)";
 638 SKIP: {
 639     skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
 640     my $cholet;
 641     open(CHOLET, ">", \$cholet);
 642     write CHOLET;
 643     close CHOLET;
 644     $foo .= "(".$cholet.")";
 645     is($foo, "(0)(1)(wellington\n)", "label before format decl");
 646 }
 647
 648 $foo = "(A)";
 649 if($foo eq $foo) {
 650     goto orinoco;
 651 }
 652 $foo .= "(X)";
 653 orinoco:
 654 sub alderney { return "tobermory"; }
 655 $foo .= "(B)";
 656 $foo .= "(".alderney().")";
 657 is($foo, "(A)(B)(tobermory)", "label before sub decl");
 658
 659 $foo = "[0:".__PACKAGE__."]";
 660 if($foo eq $foo) {
 661     goto bulgaria;
 662 }
 663 $foo .= "[9]";
 664 bulgaria:
 665 package Tomsk;
 666 $foo .= "[1:".__PACKAGE__."]";
 667 $foo .= "[2:".__PACKAGE__."]";
 668 package main;
 669 $foo .= "[3:".__PACKAGE__."]";
 670 is($foo, "[0:main][1:Tomsk][2:Tomsk][3:main]", "label before package decl");
 671
 672 $foo = "[A:".__PACKAGE__."]";
 673 if($foo eq $foo) {
 674     goto adelaide;
 675 }
 676 $foo .= "[Z]";
 677 adelaide:
 678 package Cairngorm {
 679     $foo .= "[B:".__PACKAGE__."]";
 680 }
 681 $foo .= "[C:".__PACKAGE__."]";
 682 is($foo, "[A:main][B:Cairngorm][C:main]", "label before package block");
 683
 684 our $obidos;
 685 $foo = "{0}";
 686 if($foo eq $foo) {
 687     goto shansi;
 688 }
 689 $foo .= "{9}";
 690 shansi:
 691 BEGIN { $obidos = "x"; }
 692 $foo .= "{1$obidos}";
 693 is($foo, "{0}{1x}", "label before BEGIN block");
 694
 695 $foo = "{A:".(1.5+1.5)."}";
 696 if($foo eq $foo) {
 697     goto stepney;
 698 }
 699 $foo .= "{Z}";
 700 stepney:
 701 use integer;
 702 $foo .= "{B:".(1.5+1.5)."}";
 703 is($foo, "{A:3}{B:2}", "label before use decl");
 704
 705 $foo = "<0>";
 706 if($foo eq $foo) {
 707     goto tom;
 708 }
 709 $foo .= "<9>";
 710 tom: dick: harry:
 711 $foo .= "<1>";
 712 $foo .= "<2>";
 713 is($foo, "<0><1><2>", "first of three stacked labels");
 714
 715 $foo = "<A>";
 716 if($foo eq $foo) {
 717     goto beta;
 718 }
 719 $foo .= "<Z>";
 720 alpha: beta: gamma:
 721 $foo .= "<B>";
 722 $foo .= "<C>";
 723 is($foo, "<A><B><C>", "second of three stacked labels");
 724
 725 $foo = ",0.";
 726 if($foo eq $foo) {
 727     goto gimel;
 728 }
 729 $foo .= ",9.";
 730 alef: bet: gimel:
 731 $foo .= ",1.";
 732 $foo .= ",2.";
 733 is($foo, ",0.,1.,2.", "third of three stacked labels");
 734
 735 # [perl #112316] Wrong behavior regarding labels with same prefix
 736 sub same_prefix_labels {
 737     my $pass;
 738     my $first_time = 1;
 739     CATCH: {
 740         if ( $first_time ) {
 741             CATCHLOOP: {
 742                 if ( !$first_time ) {
 743                   return 0;
 744                 }
 745                 $first_time--;
 746                 goto CATCH;
 747             }
 748         }
 749         else {
 750             return 1;
 751         }
 752     }
 753 }
 754
 755 ok(
 756    same_prefix_labels(),
 757    "perl 112316: goto and labels with the same prefix doesn't get mixed up"
 758 );
 759
 760 eval { my $x = ""; goto $x };
 761 like $@, qr/^goto must have label at /, 'goto $x where $x is empty string';
 762 eval { goto "" };
 763 like $@, qr/^goto must have label at /, 'goto ""';
 764 eval { goto };
 765 like $@, qr/^goto must have label at /, 'argless goto';
 766
 767 eval { my $x = "\0"; goto $x };
 768 like $@, qr/^Can't find label \0 at /, 'goto $x where $x begins with \0';
 769 eval { goto "\0" };
 770 like $@, qr/^Can't find label \0 at /, 'goto "\0"';
 771
 772 sub TIESCALAR { bless [pop] }
 773 sub FETCH     { $_[0][0] }
 774 tie my $t, "", sub { "cluck up porridge" };
 775 is eval { sub { goto $t }->() }//$@, 'cluck up porridge',
 776   'tied arg returning sub ref';
 777
 778 TODO: {
 779   local $::TODO = 'RT #45091: goto in CORE::GLOBAL::exit unsupported';
 780   fresh_perl_is(<<'EOC', "before\ndie handler\n", {stderr => 1}, 'RT #45091: goto in CORE::GLOBAL::EXIT');
 781   BEGIN {
 782     *CORE::GLOBAL::exit = sub {
 783       goto FASTCGI_NEXT_REQUEST;
 784     };
 785   }
 786   while (1) {
 787     eval { that_cgi_script() };
 788     FASTCGI_NEXT_REQUEST:
 789     last;
 790   }
 791
 792   sub that_cgi_script {
 793     local $SIG{__DIE__} = sub { print "die handler\n"; exit; print "exit failed?\n"; };
 794     print "before\n";
 795     eval { buggy_code() };
 796     print "after\n";
 797   }
 798   sub buggy_code {
 799     die "error!";
 800     print "after die\n";
 801   }
 802 EOC
 803 }