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