| 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, ">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 goto01; print qq[DONE\n]'); |
| 219 | is($r, "OK\nDONE\n", "goto within use-d file"); |
| 220 | unlink "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 | |