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 => 126);
  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/,pNOK//;
 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 }