t/op/eval.t

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