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 => 58;
  14 our $TODO;
  15
  16 our $foo;
  17 while ($?) {
  18     $foo = 1;
  19   label1:
  20     $foo = 2;
  21     goto label2;
  22 } continue {
  23     $foo = 0;
  24     goto label4;
  25   label3:
  26     $foo = 4;
  27     goto label4;
  28 }
  29 goto label1;
  30
  31 $foo = 3;
  32
  33 label2:
  34 is($foo, 2, 'escape while loop');
  35 goto label3;
  36
  37 label4:
  38 is($foo, 4, 'second escape while loop');
  39
  40 my $r = run_perl(prog => 'goto foo;', stderr => 1);
  41 like($r, qr/label/, 'cant find label');
  42
  43 my $ok = 0;
  44 sub foo {
  45     goto bar;
  46     return;
  47 bar:
  48     $ok = 1;
  49 }
  50
  51 &foo;
  52 ok($ok, 'goto in sub');
  53
  54 sub bar {
  55     my $x = 'bypass';
  56     eval "goto $x";
  57 }
  58
  59 &bar;
  60 exit;
  61
  62 FINALE:
  63 is(curr_test(), 16, 'FINALE');
  64
  65 # does goto LABEL handle block contexts correctly?
  66 # note that this scope-hopping differs from last & next,
  67 # which always go up-scope strictly.
  68 my $count = 0;
  69 my $cond = 1;
  70 for (1) {
  71     if ($cond == 1) {
  72         $cond = 0;
  73         goto OTHER;
  74     }
  75     elsif ($cond == 0) {
  76       OTHER:
  77         $cond = 2;
  78         is($count, 0, 'OTHER');
  79         $count++;
  80         goto THIRD;
  81     }
  82     else {
  83       THIRD:
  84         is($count, 1, 'THIRD');
  85         $count++;
  86     }
  87 }
  88 is($count, 2, 'end of loop');
  89
  90 # Does goto work correctly within a for(;;) loop?
  91 #  (BUG ID 20010309.004)
  92
  93 for(my $i=0;!$i++;) {
  94   my $x=1;
  95   goto label;
  96   label: is($x, 1, 'goto inside a for(;;) loop body from inside the body');
  97 }
  98
  99 # Does goto work correctly going *to* a for(;;) loop?
 100 #  (make sure it doesn't skip the initializer)
 101
 102 my ($z, $y) = (0);
 103 FORL1: for ($y=1; $z;) {
 104     ok($y, 'goto a for(;;) loop, from outside (does initializer)');
 105     goto TEST19}
 106 ($y,$z) = (0, 1);
 107 goto FORL1;
 108
 109 # Even from within the loop?
 110 TEST19: $z = 0;
 111 FORL2: for($y=1; 1;) {
 112   if ($z) {
 113     ok($y, 'goto a for(;;) loop, from inside (does initializer)');
 114     last;
 115   }
 116   ($y, $z) = (0, 1);
 117   goto FORL2;
 118 }
 119
 120 # Does goto work correctly within a try block?
 121 #  (BUG ID 20000313.004) - [perl #2359]
 122 $ok = 0;
 123 eval {
 124   my $variable = 1;
 125   goto LABEL20;
 126   LABEL20: $ok = 1 if $variable;
 127 };
 128 ok($ok, 'works correctly within a try block');
 129 is($@, "", '...and $@ not set');
 130
 131 # And within an eval-string?
 132 $ok = 0;
 133 eval q{
 134   my $variable = 1;
 135   goto LABEL21;
 136   LABEL21: $ok = 1 if $variable;
 137 };
 138 ok($ok, 'works correctly within an eval string');
 139 is($@, "", '...and $@ still not set');
 140
 141
 142 # Test that goto works in nested eval-string
 143 $ok = 0;
 144 {eval q{
 145   eval q{
 146     goto LABEL22;
 147   };
 148   $ok = 0;
 149   last;
 150
 151   LABEL22: $ok = 1;
 152 };
 153 $ok = 0 if $@;
 154 }
 155 ok($ok, 'works correctly in a nested eval string');
 156
 157 {
 158     my $false = 0;
 159     my $count;
 160
 161     $ok = 0;
 162     { goto A; A: $ok = 1 } continue { }
 163     ok($ok, '#20357 goto inside /{ } continue { }/ loop');
 164
 165     $ok = 0;
 166     { do { goto A; A: $ok = 1 } while $false }
 167     ok($ok, '#20154 goto inside /do { } while ()/ loop');
 168     $ok = 0;
 169     foreach(1) { goto A; A: $ok = 1 } continue { };
 170     ok($ok, 'goto inside /foreach () { } continue { }/ loop');
 171
 172     $ok = 0;
 173     sub a {
 174         A: { if ($false) { redo A; B: $ok = 1; redo A; } }
 175         goto B unless $count++;
 176     }
 177     a();
 178     ok($ok, '#19061 loop label wiped away by goto');
 179
 180     $ok = 0;
 181     my $p;
 182     for ($p=1;$p && goto A;$p=0) { A: $ok = 1 }
 183     ok($ok, 'weird case of goto and for(;;) loop');
 184 }
 185
 186 # bug #9990 - don't prematurely free the CV we're &going to.
 187
 188 sub f1 {
 189     my $x;
 190     goto sub { $x=0; ok(1,"don't prematurely free CV\n") }
 191 }
 192 f1();
 193
 194 # bug #22181 - this used to coredump or make $x undefined, due to
 195 # erroneous popping of the inner BLOCK context
 196
 197 undef $ok;
 198 for ($count=0; $count<2; $count++) {
 199     my $x = 1;
 200     goto LABEL29;
 201     LABEL29:
 202     $ok = $x;
 203 }
 204 is($ok, 1, 'goto in for(;;) with continuation');
 205
 206 # bug #22299 - goto in require doesn't find label
 207
 208 open my $f, ">Op_goto01.pm" or die;
 209 print $f <<'EOT';
 210 package goto01;
 211 goto YYY;
 212 die;
 213 YYY: print "OK\n";
 214 1;
 215 EOT
 216 close $f;
 217
 218 $r = runperl(prog => 'use Op_goto01; print qq[DONE\n]');
 219 is($r, "OK\nDONE\n", "goto within use-d file");
 220 unlink "Op_goto01.pm";
 221
 222 # test for [perl #24108]
 223 $ok = 1;
 224 $count = 0;
 225 sub i_return_a_label {
 226     $count++;
 227     return "returned_label";
 228 }
 229 eval { goto +i_return_a_label; };
 230 $ok = 0;
 231
 232 returned_label:
 233 is($count, 1, 'called i_return_a_label');
 234 ok($ok, 'skipped to returned_label');
 235
 236 # [perl #29708] - goto &foo could leave foo() at depth two with
 237 # @_ == PL_sv_undef, causing a coredump
 238
 239
 240 $r = runperl(
 241     prog =>
 242         'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)',
 243     stderr => 1
 244     );
 245 is($r, "ok\n", 'avoid pad without an @_');
 246
 247 goto moretests;
 248 fail('goto moretests');
 249 exit;
 250
 251 bypass:
 252
 253 is(curr_test(), 5, 'eval "goto $x"');
 254
 255 # Test autoloading mechanism.
 256
 257 sub two {
 258     my ($pack, $file, $line) = caller;  # Should indicate original call stats.
 259     is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE",
 260         'autoloading mechanism.');
 261 }
 262
 263 sub one {
 264     eval <<'END';
 265     no warnings 'redefine';
 266     sub one { pass('sub one'); goto &two; fail('sub one tail'); }
 267 END
 268     goto &one;
 269 }
 270
 271 $::FILE = __FILE__;
 272 $::LINE = __LINE__ + 1;
 273 &one(1,2,3);
 274
 275 {
 276     my $wherever = 'NOWHERE';
 277     eval { goto $wherever };
 278     like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@');
 279 }
 280
 281 # see if a modified @_ propagates
 282 {
 283   my $i;
 284   package Foo;
 285   sub DESTROY   { my $s = shift; ::is($s->[0], $i, "destroy $i"); }
 286   sub show      { ::is(+@_, 5, "show $i",); }
 287   sub start     { push @_, 1, "foo", {}; goto &show; }
 288   for (1..3)    { $i = $_; start(bless([$_]), 'bar'); }
 289 }
 290
 291 sub auto {
 292     goto &loadit;
 293 }
 294
 295 sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
 296
 297 $ok = 0;
 298 auto("foo");
 299 ok($ok, 'autoload');
 300
 301 {
 302     my $wherever = 'FINALE';
 303     goto $wherever;
 304 }
 305 fail('goto $wherever');
 306
 307 moretests:
 308 # test goto duplicated labels.
 309 {
 310     my $z = 0;
 311     eval {
 312         $z = 0;
 313         for (0..1) {
 314           L4: # not outer scope
 315             $z += 10;
 316             last;
 317         }
 318         goto L4 if $z == 10;
 319         last;
 320     };
 321     like($@, qr/Can't "goto" into the middle of a foreach loop/,
 322             'catch goto middle of foreach');
 323
 324     $z = 0;
 325     # ambiguous label resolution (outer scope means endless loop!)
 326   L1:
 327     for my $x (0..1) {
 328         $z += 10;
 329         is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)');
 330         goto L1 unless $x;
 331         $z += 10;
 332       L1:
 333         is($z, 10, 'prefer same scope: second');
 334         last;
 335     }
 336
 337     $z = 0;
 338   L2:
 339     {
 340         $z += 10;
 341         is($z, 10, 'prefer this scope (block body) to outer scope (block entry)');
 342         goto L2 if $z == 10;
 343         $z += 10;
 344       L2:
 345         is($z, 10, 'prefer this scope: second');
 346     }
 347
 348
 349     {
 350         $z = 0;
 351         while (1) {
 352           L3: # not inner scope
 353             $z += 10;
 354             last;
 355         }
 356         is($z, 10, 'prefer this scope to inner scope');
 357         goto L3 if $z == 10;
 358         $z += 10;
 359       L3: # this scope !
 360         is($z, 10, 'prefer this scope to inner scope: second');
 361     }
 362
 363   L4: # not outer scope
 364     {
 365         $z = 0;
 366         while (1) {
 367           L4: # not inner scope
 368             $z += 1;
 369             last;
 370         }
 371         is($z, 1, 'prefer this scope to inner,outer scopes');
 372         goto L4 if $z == 1;
 373         $z += 10;
 374       L4: # this scope !
 375         is($z, 1, 'prefer this scope to inner,outer scopes: second');
 376     }
 377
 378     {
 379         my $loop = 0;
 380         for my $x (0..1) {
 381           L2: # without this, fails 1 (middle) out of 3 iterations
 382             $z = 0;
 383           L2:
 384             $z += 10;
 385             is($z, 10,
 386                 "same label, multiple times in same scope (choose 1st) $loop");
 387             goto L2 if $z == 10 and not $loop++;
 388         }
 389     }
 390 }
 391
 392 # deep recursion with gotos eventually caused a stack reallocation
 393 # which messed up buggy internals that didn't expect the stack to move
 394
 395 sub recurse1 {
 396     unshift @_, "x";
 397     no warnings 'recursion';
 398     goto &recurse2;
 399 }
 400 sub recurse2 {
 401     my $x = shift;
 402     $_[0] ? +1 + recurse1($_[0] - 1) : 0
 403 }
 404 is(recurse1(500), 500, 'recursive goto &foo');
 405
 406 # [perl #32039] Chained goto &sub drops data too early.
 407
 408 sub a32039 { @_=("foo"); goto &b32039; }
 409 sub b32039 { goto &c32039; }
 410 sub c32039 { is($_[0], 'foo', 'chained &goto') }
 411 a32039();
 412
 413 # [perl #35214] next and redo re-entered the loop with the wrong cop,
 414 # causing a subsequent goto to crash
 415
 416 {
 417     my $r = runperl(
 418                 stderr => 1,
 419                 prog =>
 420 'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)'
 421     );
 422     is($r, "ok\n", 'next and goto');
 423
 424     $r = runperl(
 425                 stderr => 1,
 426                 prog =>
 427 'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)'
 428     );
 429     is($r, "ok\n", 'redo and goto');
 430 }
 431
 432 # goto &foo not allowed in evals
 433
 434
 435 sub null { 1 };
 436 eval 'goto &null';
 437 like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
 438 eval { goto &null };
 439 like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
 440
 441 # [perl #36521] goto &foo in warn handler could defeat recursion avoider
 442
 443 {
 444     my $r = runperl(
 445                 stderr => 1,
 446                 prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
 447     );
 448     like($r, qr/bar/, "goto &foo in warn");
 449 }
 450
 451 TODO: {
 452     local $TODO = "[perl #43403] goto() from an if to an else doesn't undo local () changes";
 453     our $global = "unmodified";
 454     if ($global) { # true but not constant-folded
 455          local $global = "modified";
 456          goto ELSE;
 457     } else {
 458          ELSE: is($global, "unmodified");
 459     }
 460 }
 461