t/op/eval.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan(tests => 128);
  10
  11 eval 'pass();';
  12
  13 is($@, '');
  14
  15 eval "\$foo\n    = # this is a comment\n'ok 3';";
  16 is($foo, 'ok 3');
  17
  18 eval "\$foo\n    = # this is a comment\n'ok 4\n';";
  19 is($foo, "ok 4\n");
  20
  21 print eval '
  22 $foo =;';               # this tests for a call through yyerror()
  23 like($@, qr/line 2/);
  24
  25 print eval '$foo = /';  # this tests for a call through fatal()
  26 like($@, qr/Search/);
  27
  28 is scalar(eval '++'), undef, 'eval syntax error in scalar context';
  29 is scalar(eval 'die'), undef, 'eval run-time error in scalar context';
  30 is +()=eval '++', 0, 'eval syntax error in list context';
  31 is +()=eval 'die', 0, 'eval run-time error in list context';
  32
  33 is(eval '"ok 7\n";', "ok 7\n");
  34
  35 $foo = 5;
  36 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
  37 $ans = eval $fact;
  38 is($ans, 120, 'calculate a factorial with recursive evals');
  39
  40 $foo = 5;
  41 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
  42 $ans = eval $fact;
  43 is($ans, 120, 'calculate a factorial with recursive evals');
  44
  45 my $curr_test = curr_test();
  46 my $tempfile = tempfile();
  47 open(try,'>',$tempfile);
  48 print try 'print "ok $curr_test\n";',"\n";
  49 close try;
  50
  51 do "./$tempfile"; print $@;
  52
  53 # Test the singlequoted eval optimizer
  54
  55 $i = $curr_test + 1;
  56 for (1..3) {
  57     eval 'print "ok ", $i++, "\n"';
  58 }
  59
  60 $curr_test += 4;
  61
  62 eval {
  63     print "ok $curr_test\n";
  64     die sprintf "ok %d\n", $curr_test + 2;
  65     1;
  66 } || printf "ok %d\n$@", $curr_test + 1;
  67
  68 curr_test($curr_test + 3);
  69
  70 # check whether eval EXPR determines value of EXPR correctly
  71
  72 {
  73   my @a = qw(a b c d);
  74   my @b = eval @a;
  75   is("@b", '4');
  76   is($@, '');
  77
  78   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
  79   my $b;
  80   @a = eval $a;
  81   is("@a", 'A');
  82   is(  $b, 'A');
  83   $_ = eval $a;
  84   is(  $b, 'S');
  85   eval $a;
  86   is(  $b, 'V');
  87
  88   $b = 'wrong';
  89   $x = sub {
  90      my $b = "right";
  91      is(eval('"$b"'), $b);
  92   };
  93   &$x();
  94 }
  95
  96 {
  97   my $b = 'wrong';
  98   my $X = sub {
  99      my $b = "right";
 100      is(eval('"$b"'), $b);
 101   };
 102   &$X();
 103 }
 104
 105 # check navigation of multiple eval boundaries to find lexicals
 106
 107 my $x = 'aa';
 108 eval <<'EOT'; die if $@;
 109   print "# $x\n";       # clone into eval's pad
 110   sub do_eval1 {
 111      eval $_[0]; die if $@;
 112   }
 113 EOT
 114 do_eval1('is($x, "aa")');
 115 $x++;
 116 do_eval1('eval q[is($x, "ab")]');
 117 $x++;
 118 do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
 119 $x++;
 120
 121 # calls from within eval'' should clone outer lexicals
 122
 123 eval <<'EOT'; die if $@;
 124   sub do_eval2 {
 125      eval $_[0]; die if $@;
 126   }
 127 do_eval2('is($x, "ad")');
 128 $x++;
 129 do_eval2('eval q[is($x, "ae")]');
 130 $x++;
 131 do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
 132 EOT
 133
 134 # calls outside eval'' should NOT clone lexicals from called context
 135
 136 $main::ok = 'not ok';
 137 my $ok = 'ok';
 138 eval <<'EOT'; die if $@;
 139   # $x unbound here
 140   sub do_eval3 {
 141      eval $_[0]; die if $@;
 142   }
 143 EOT
 144 {
 145     my $ok = 'not ok';
 146     do_eval3('is($ok, q{ok})');
 147     do_eval3('eval q[is($ok, q{ok})]');
 148     do_eval3('sub { eval q[is($ok, q{ok})] }->()');
 149 }
 150
 151 {
 152     my $x = curr_test();
 153     my $got;
 154     sub recurse {
 155         my $l = shift;
 156         if ($l < $x) {
 157             ++$l;
 158             eval 'print "# level $l\n"; recurse($l);';
 159             die if $@;
 160         }
 161         else {
 162             $got = "ok $l";
 163         }
 164     }
 165     local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ };
 166     recurse(curr_test() - 5);
 167
 168     is($got, "ok $x",
 169        "recursive subroutine-call inside eval'' see its own lexicals");
 170 }
 171
 172
 173 eval <<'EOT';
 174   sub create_closure {
 175     my $self = shift;
 176     return sub {
 177        return $self;
 178     };
 179   }
 180 EOT
 181 is(create_closure("good")->(), "good",
 182    'closures created within eval bind correctly');
 183
 184 $main::r = "good";
 185 sub terminal { eval '$r . q{!}' }
 186 is(do {
 187    my $r = "bad";
 188    eval 'terminal($r)';
 189 }, 'good!', 'lexical search terminates correctly at subroutine boundary');
 190
 191 {
 192     # Have we cured panic which occurred with require/eval in die handler ?
 193     local $SIG{__DIE__} = sub { eval {1}; die shift };
 194     eval { die "wham_eth\n" };
 195     is($@, "wham_eth\n");
 196 }
 197
 198 {
 199     my $c = eval "(1,2)x10";
 200     is($c, '2222222222', 'scalar eval"" pops stack correctly');
 201 }
 202
 203 # return from eval {} should clear $@ correctly
 204 {
 205     my $status = eval {
 206         eval { die };
 207         print "# eval { return } test\n";
 208         return; # removing this changes behavior
 209     };
 210     is($@, '', 'return from eval {} should clear $@ correctly');
 211 }
 212
 213 # ditto for eval ""
 214 {
 215     my $status = eval q{
 216         eval q{ die };
 217         print "# eval q{ return } test\n";
 218         return; # removing this changes behavior
 219     };
 220     is($@, '', 'return from eval "" should clear $@ correctly');
 221 }
 222
 223 # Check that eval catches bad goto calls
 224 #   (BUG ID 20010305.003)
 225 {
 226     eval {
 227         eval { goto foo; };
 228         like($@, qr/Can't "goto" into the middle of a foreach loop/,
 229              'eval catches bad goto calls');
 230         last;
 231         foreach my $i (1) {
 232             foo: fail('jumped into foreach');
 233         }
 234     };
 235     fail("Outer eval didn't execute the last");
 236     diag($@);
 237 }
 238
 239 # Make sure that "my $$x" is forbidden
 240 # 20011224 MJD
 241 {
 242     foreach (qw($$x @$x %$x $$$x)) {
 243         eval 'my ' . $_;
 244         isnt($@, '', "my $_ is forbidden");
 245     }
 246 }
 247
 248 {
 249     $@ = 5;
 250     eval q{};
 251     cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
 252 }
 253
 254 # DAPM Nov-2002. Perl should now capture the full lexical context during
 255 # evals.
 256
 257 $::zzz = $::zzz = 0;
 258 my $zzz = 1;
 259
 260 eval q{
 261     sub fred1 {
 262         eval q{ is(eval '$zzz', 1); }
 263     }
 264     fred1(47);
 265     { my $zzz = 2; fred1(48) }
 266 };
 267
 268 eval q{
 269     sub fred2 {
 270         is(eval('$zzz'), 1);
 271     }
 272 };
 273 fred2(49);
 274 { my $zzz = 2; fred2(50) }
 275
 276 # sort() starts a new context stack. Make sure we can still find
 277 # the lexically enclosing sub
 278
 279 sub do_sort {
 280     my $zzz = 2;
 281     my @a = sort
 282             { is(eval('$zzz'), 2); $a <=> $b }
 283             2, 1;
 284 }
 285 do_sort();
 286
 287 # more recursion and lexical scope leak tests
 288
 289 eval q{
 290     my $r = -1;
 291     my $yyy = 9;
 292     sub fred3 {
 293         my $l = shift;
 294         my $r = -2;
 295         return 1 if $l < 1;
 296         return 0 if eval '$zzz' != 1;
 297         return 0 if       $yyy  != 9;
 298         return 0 if eval '$yyy' != 9;
 299         return 0 if eval '$l' != $l;
 300         return $l * fred3($l-1);
 301     }
 302     my $r = fred3(5);
 303     is($r, 120);
 304     $r = eval'fred3(5)';
 305     is($r, 120);
 306     $r = 0;
 307     eval '$r = fred3(5)';
 308     is($r, 120);
 309     $r = 0;
 310     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
 311     is($r, 120);
 312 };
 313 my $r = fred3(5);
 314 is($r, 120);
 315 $r = eval'fred3(5)';
 316 is($r, 120);
 317 $r = 0;
 318 eval'$r = fred3(5)';
 319 is($r, 120);
 320 $r = 0;
 321 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
 322 is($r, 120);
 323
 324 # check that goto &sub within evals doesn't leak lexical scope
 325
 326 my $yyy = 2;
 327
 328 sub fred4 {
 329     my $zzz = 3;
 330     is($zzz, 3);
 331     is(eval '$zzz', 3);
 332     is(eval '$yyy', 2);
 333 }
 334
 335 eval q{
 336     fred4();
 337     sub fred5 {
 338         my $zzz = 4;
 339         is($zzz, 4);
 340         is(eval '$zzz', 4);
 341         is(eval '$yyy', 2);
 342         goto &fred4;
 343     }
 344     fred5();
 345 };
 346 fred5();
 347 { my $yyy = 88; my $zzz = 99; fred5(); }
 348 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
 349
 350 {
 351    $eval = eval 'sub { eval "sub { %S }" }';
 352    $eval->({});
 353    pass('[perl #9728] used to dump core');
 354 }
 355
 356 # evals that appear in the DB package should see the lexical scope of the
 357 # thing outside DB that called them (usually the debugged code), rather
 358 # than the usual surrounding scope
 359
 360 our $x = 1;
 361 {
 362     my $x=2;
 363     sub db1     { $x; eval '$x' }
 364     sub DB::db2 { $x; eval '$x' }
 365     package DB;
 366     sub db3     { eval '$x' }
 367     sub DB::db4 { eval '$x' }
 368     sub db5     { my $x=4; eval '$x' }
 369     package main;
 370     sub db6     { my $x=4; eval '$x' }
 371 }
 372 {
 373     my $x = 3;
 374     is(db1(),      2);
 375     is(DB::db2(),  2);
 376     is(DB::db3(),  3);
 377     is(DB::db4(),  3);
 378     is(DB::db5(),  3);
 379     is(db6(),      4);
 380 }
 381
 382 # [perl #19022] used to end up with shared hash warnings
 383 # The program should generate no output, so anything we see is on stderr
 384 my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
 385                    stderr => 1);
 386 is ($got, '');
 387
 388 # And a buggy way of fixing #19022 made this fail - $k became undef after the
 389 # eval for a build with copy on write
 390 {
 391   my %h;
 392   $h{a}=1;
 393   foreach my $k (keys %h) {
 394     is($k, 'a');
 395
 396     eval "\$k";
 397
 398     is($k, 'a');
 399   }
 400 }
 401
 402 sub Foo {} print Foo(eval {});
 403 pass('#20798 (used to dump core)');
 404
 405 # check for context in string eval
 406 {
 407   my(@r,$r,$c);
 408   sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
 409
 410   my $code = q{ context() };
 411   @r = qw( a b );
 412   $r = 'ab';
 413   @r = eval $code;
 414   is("@r$c", 'AA', 'string eval list context');
 415   $r = eval $code;
 416   is("$r$c", 'SS', 'string eval scalar context');
 417   eval $code;
 418   is("$c", 'V', 'string eval void context');
 419 }
 420
 421 # [perl #34682] escaping an eval with last could coredump or dup output
 422
 423 $got = runperl (
 424     prog =>
 425     'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
 426 stderr => 1);
 427
 428 is($got, "ok\n", 'eval and last');
 429
 430 # eval undef should be the same as eval "" barring any warnings
 431
 432 {
 433     local $@ = "foo";
 434     eval undef;
 435     is($@, "", 'eval undef');
 436 }
 437
 438 {
 439     no warnings;
 440     eval "&& $b;";
 441     like($@, qr/^syntax error/, 'eval syntax error, no warnings');
 442 }
 443
 444 # a syntax error in an eval called magically (eg via tie or overload)
 445 # resulted in an assertion failure in S_docatch, since doeval had already
 446 # popped the EVAL context due to the failure, but S_docatch expected the
 447 # context to still be there.
 448
 449 {
 450     my $ok  = 0;
 451     package Eval1;
 452     sub STORE { eval '('; $ok = 1 }
 453     sub TIESCALAR { bless [] }
 454
 455     my $x;
 456     tie $x, bless [];
 457     $x = 1;
 458     ::is($ok, 1, 'eval docatch');
 459 }
 460
 461 # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
 462 # length $@
 463 $@ = "";
 464 eval { die "\x{a10d}"; };
 465 $_ = length $@;
 466 eval { 1 };
 467
 468 cmp_ok($@, 'eq', "", 'length of $@ after eval');
 469 cmp_ok(length $@, '==', 0, 'length of $@ after eval');
 470
 471 # Check if eval { 1 }; completely resets $@
 472 SKIP: {
 473     skip_if_miniperl('no dynamic loading on miniperl, no Devel::Peek', 2);
 474     require Config;
 475     skip('Devel::Peek was not built', 2)
 476         unless $Config::Config{extensions} =~ /\bDevel\/Peek\b/;
 477
 478     my $tempfile = tempfile();
 479     open $prog, ">", $tempfile or die "Can't create test file";
 480     print $prog <<'END_EVAL_TEST';
 481     use Devel::Peek;
 482     $! = 0;
 483     $@ = $!;
 484     Dump($@);
 485     print STDERR "******\n";
 486     eval { die "\x{a10d}"; };
 487     $_ = length $@;
 488     eval { 1 };
 489     Dump($@);
 490     print STDERR "******\n";
 491     print STDERR "Done\n";
 492 END_EVAL_TEST
 493     close $prog or die "Can't close $tempfile: $!";
 494     my $got = runperl(progfile => $tempfile, stderr => 1);
 495     my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got);
 496
 497     is($tombstone, "Done\n", 'Program completed successfully');
 498
 499     $first =~ s/p?[NI]OK,//g;
 500     s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
 501     s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
 502     # Dump may double newlines through pipes, though not files
 503     # which is what this test used to use.
 504     $second =~ s/ IV = 0\n\n/ IV = 0\n/ if $^O eq 'VMS';
 505
 506     is($second, $first, 'eval { 1 } completely resets $@');
 507 }
 508
 509 # Test that "use feature" and other hint transmission in evals and s///ee
 510 # don't leak memory
 511 {
 512     use feature qw(:5.10);
 513     my $count_expected = ($^H & 0x20000) ? 2 : 1;
 514     my $t;
 515     my $s = "a";
 516     $s =~ s/a/$t = \%^H;  qq( qq() );/ee;
 517     is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
 518 }
 519
 520 {
 521     # test that the CV compiled for the eval is freed by checking that no additional
 522     # reference to outside lexicals are made.
 523     my $x;
 524     is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
 525     eval '$x';
 526     is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
 527 }
 528
 529 fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
 530 $::{'@'}='';
 531 eval {};
 532 print "ok\n";
 533 EOP
 534
 535 fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
 536 eval {
 537     $::{'@'}='';
 538 };
 539 print "ok\n";
 540 EOP
 541
 542 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
 543 $::{'@'}=\3;
 544 eval {};
 545 print "ok\n";
 546 EOP
 547
 548 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
 549 eval {
 550     $::{'@'}=\3;
 551 };
 552 print "ok\n";
 553 EOP
 554
 555     fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals');
 556 # localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ
 557 BEGIN { $^H |= 0x00020000 }
 558 eval q{ eval { + } };
 559 print "ok\n";
 560 EOP
 561
 562 fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
 563 use overload '""'  => sub { '1;' };
 564 my $ov = bless [];
 565 eval $ov;
 566 print "ok\n";
 567 EOP
 568
 569 for my $k (!0) {
 570   eval 'my $do_something_with = $k';
 571   eval { $k = 'mon' };
 572   is "a" =~ /a/, "1",
 573     "string eval leaves readonly lexicals readonly [perl #19135]";
 574 }
 575
 576 # [perl #68750]
 577 fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H');
 578   BEGIN {
 579     require re; re->import('/x'); # should only affect surrounding scope
 580     eval '
 581       print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
 582       use re "/m";
 583       print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
 584    ';
 585   }
 586   print "ab" =~ /a b/ ? "ok\n" : "nokay\n";
 587 EOP
 588
 589 # [perl #70151]
 590 {
 591     BEGIN { eval 'require re; import re "/x"' }
 592     ok "ab" =~ /a b/, 'eval does not localise %^H at run time';
 593 }
 594
 595 # The fix for perl #70151 caused an assertion failure that broke
 596 # SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails.
 597 eval(q|""!=!~//|);
 598 pass("phew! dodged the assertion after a parsing (not lexing) error");
 599
 600 # [perl #111462]
 601 {
 602    local $ENV{PERL_DESTRUCT_LEVEL} = 1;
 603    unlike
 604      runperl(
 605       prog => 'BEGIN { $^H{foo} = bar }'
 606              .'our %FIELDS; my main $x; eval q[$x->{foo}]',
 607       stderr => 1,
 608      ),
 609      qr/Unbalanced string table/,
 610     'Errors in finalize_optree do not leak string eval op tree';
 611 }
 612
 613 # [perl #114658] Line numbers at end of string eval
 614 for("{;", "{") {
 615     eval $_; is $@ =~ s/eval \d+/eval 1/rag, <<'EOE',
 616 Missing right curly or square bracket at (eval 1) line 1, at end of line
 617 syntax error at (eval 1) line 1, at EOF
 618 EOE
 619         qq'Right line number for eval "$_"';
 620 }