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