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