t/op/eval.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 print "1..92\n";
   9
  10 eval 'print "ok 1\n";';
  11
  12 if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
  13
  14 eval "\$foo\n    = # this is a comment\n'ok 3';";
  15 print $foo,"\n";
  16
  17 eval "\$foo\n    = # this is a comment\n'ok 4\n';";
  18 print $foo;
  19
  20 print eval '
  21 $foo =;';               # this tests for a call through yyerror()
  22 if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
  23
  24 print eval '$foo = /';  # this tests for a call through fatal()
  25 if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
  26
  27 print eval '"ok 7\n";';
  28
  29 # calculate a factorial with recursive evals
  30
  31 $foo = 5;
  32 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
  33 $ans = eval $fact;
  34 if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
  35
  36 $foo = 5;
  37 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
  38 $ans = eval $fact;
  39 if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
  40
  41 open(try,'>Op.eval');
  42 print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
  43 close try;
  44
  45 do './Op.eval'; print $@;
  46
  47 # Test the singlequoted eval optimizer
  48
  49 $i = 11;
  50 for (1..3) {
  51     eval 'print "ok ", $i++, "\n"';
  52 }
  53
  54 eval {
  55     print "ok 14\n";
  56     die "ok 16\n";
  57     1;
  58 } || print "ok 15\n$@";
  59
  60 # check whether eval EXPR determines value of EXPR correctly
  61
  62 {
  63   my @a = qw(a b c d);
  64   my @b = eval @a;
  65   print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
  66   print $@ ? "not ok 18\n" : "ok 18\n";
  67
  68   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
  69   my $b;
  70   @a = eval $a;
  71   print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
  72   print   $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
  73   $_ = eval $a;
  74   print   $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
  75   eval $a;
  76   print   $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
  77
  78   $b = 'wrong';
  79   $x = sub {
  80      my $b = "right";
  81      print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
  82   };
  83   &$x();
  84 }
  85
  86 my $b = 'wrong';
  87 my $X = sub {
  88    my $b = "right";
  89    print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
  90 };
  91 &$X();
  92
  93
  94 # check navigation of multiple eval boundaries to find lexicals
  95
  96 my $x = 25;
  97 eval <<'EOT'; die if $@;
  98   print "# $x\n";       # clone into eval's pad
  99   sub do_eval1 {
 100      eval $_[0]; die if $@;
 101   }
 102 EOT
 103 do_eval1('print "ok $x\n"');
 104 $x++;
 105 do_eval1('eval q[print "ok $x\n"]');
 106 $x++;
 107 do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
 108 $x++;
 109
 110 # calls from within eval'' should clone outer lexicals
 111
 112 eval <<'EOT'; die if $@;
 113   sub do_eval2 {
 114      eval $_[0]; die if $@;
 115   }
 116 do_eval2('print "ok $x\n"');
 117 $x++;
 118 do_eval2('eval q[print "ok $x\n"]');
 119 $x++;
 120 do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
 121 $x++;
 122 EOT
 123
 124 # calls outside eval'' should NOT clone lexicals from called context
 125
 126 $main::ok = 'not ok';
 127 my $ok = 'ok';
 128 eval <<'EOT'; die if $@;
 129   # $x unbound here
 130   sub do_eval3 {
 131      eval $_[0]; die if $@;
 132   }
 133 EOT
 134 {
 135     my $ok = 'not ok';
 136     do_eval3('print "$ok ' . $x++ . '\n"');
 137     do_eval3('eval q[print "$ok ' . $x++ . '\n"]');
 138     do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()');
 139 }
 140
 141 # can recursive subroutine-call inside eval'' see its own lexicals?
 142 sub recurse {
 143   my $l = shift;
 144   if ($l < $x) {
 145      ++$l;
 146      eval 'print "# level $l\n"; recurse($l);';
 147      die if $@;
 148   }
 149   else {
 150     print "ok $l\n";
 151   }
 152 }
 153 {
 154   local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
 155   recurse($x-5);
 156 }
 157 $x++;
 158
 159 # do closures created within eval bind correctly?
 160 eval <<'EOT';
 161   sub create_closure {
 162     my $self = shift;
 163     return sub {
 164        print $self;
 165     };
 166   }
 167 EOT
 168 create_closure("ok $x\n")->();
 169 $x++;
 170
 171 # does lexical search terminate correctly at subroutine boundary?
 172 $main::r = "ok $x\n";
 173 sub terminal { eval 'print $r' }
 174 {
 175    my $r = "not ok $x\n";
 176    eval 'terminal($r)';
 177 }
 178 $x++;
 179
 180 # Have we cured panic which occurred with require/eval in die handler ?
 181 $SIG{__DIE__} = sub { eval {1}; die shift };
 182 eval { die "ok ".$x++,"\n" };
 183 print $@;
 184
 185 # does scalar eval"" pop stack correctly?
 186 {
 187     my $c = eval "(1,2)x10";
 188     print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
 189     $x++;
 190 }
 191
 192 # return from eval {} should clear $@ correctly
 193 {
 194     my $status = eval {
 195         eval { die };
 196         print "# eval { return } test\n";
 197         return; # removing this changes behavior
 198     };
 199     print "not " if $@;
 200     print "ok $x\n";
 201     $x++;
 202 }
 203
 204 # ditto for eval ""
 205 {
 206     my $status = eval q{
 207         eval q{ die };
 208         print "# eval q{ return } test\n";
 209         return; # removing this changes behavior
 210     };
 211     print "not " if $@;
 212     print "ok $x\n";
 213     $x++;
 214 }
 215
 216 # Check that eval catches bad goto calls
 217 #   (BUG ID 20010305.003)
 218 {
 219     eval {
 220         eval { goto foo; };
 221         print ($@ ? "ok 41\n" : "not ok 41\n");
 222         last;
 223         foreach my $i (1) {
 224             foo: print "not ok 41\n";
 225             print "# jumped into foreach\n";
 226         }
 227     };
 228     print "not ok 41\n" if $@;
 229 }
 230
 231 # Make sure that "my $$x" is forbidden
 232 # 20011224 MJD
 233 {
 234   eval q{my $$x};
 235   print $@ ? "ok 42\n" : "not ok 42\n";
 236   eval q{my @$x};
 237   print $@ ? "ok 43\n" : "not ok 43\n";
 238   eval q{my %$x};
 239   print $@ ? "ok 44\n" : "not ok 44\n";
 240   eval q{my $$$x};
 241   print $@ ? "ok 45\n" : "not ok 45\n";
 242 }
 243
 244 # [ID 20020623.002] eval "" doesn't clear $@
 245 {
 246     $@ = 5;
 247     eval q{};
 248     print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
 249 }
 250
 251 # DAPM Nov-2002. Perl should now capture the full lexical context during
 252 # evals.
 253
 254 $::zzz = $::zzz = 0;
 255 my $zzz = 1;
 256
 257 eval q{
 258     sub fred1 {
 259         eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
 260     }
 261     fred1(47);
 262     { my $zzz = 2; fred1(48) }
 263 };
 264
 265 eval q{
 266     sub fred2 {
 267         print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
 268     }
 269 };
 270 fred2(49);
 271 { my $zzz = 2; fred2(50) }
 272
 273 # sort() starts a new context stack. Make sure we can still find
 274 # the lexically enclosing sub
 275
 276 sub do_sort {
 277     my $zzz = 2;
 278     my @a = sort
 279             { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
 280             2, 1;
 281 }
 282 do_sort();
 283
 284 # more recursion and lexical scope leak tests
 285
 286 eval q{
 287     my $r = -1;
 288     my $yyy = 9;
 289     sub fred3 {
 290         my $l = shift;
 291         my $r = -2;
 292         return 1 if $l < 1;
 293         return 0 if eval '$zzz' != 1;
 294         return 0 if       $yyy  != 9;
 295         return 0 if eval '$yyy' != 9;
 296         return 0 if eval '$l' != $l;
 297         return $l * fred3($l-1);
 298     }
 299     my $r = fred3(5);
 300     print $r == 120 ? 'ok' : 'not ok', " 52\n";
 301     $r = eval'fred3(5)';
 302     print $r == 120 ? 'ok' : 'not ok', " 53\n";
 303     $r = 0;
 304     eval '$r = fred3(5)';
 305     print $r == 120 ? 'ok' : 'not ok', " 54\n";
 306     $r = 0;
 307     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
 308     print $r == 120 ? 'ok' : 'not ok', " 55\n";
 309 };
 310 my $r = fred3(5);
 311 print $r == 120 ? 'ok' : 'not ok', " 56\n";
 312 $r = eval'fred3(5)';
 313 print $r == 120 ? 'ok' : 'not ok', " 57\n";
 314 $r = 0;
 315 eval'$r = fred3(5)';
 316 print $r == 120 ? 'ok' : 'not ok', " 58\n";
 317 $r = 0;
 318 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
 319 print $r == 120 ? 'ok' : 'not ok', " 59\n";
 320
 321 # check that goto &sub within evals doesn't leak lexical scope
 322
 323 my $yyy = 2;
 324
 325 my $test = 60;
 326 sub fred4 {
 327     my $zzz = 3;
 328     print +($zzz == 3  && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
 329     $test++;
 330     print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
 331     $test++;
 332 }
 333
 334 eval q{
 335     fred4();
 336     sub fred5 {
 337         my $zzz = 4;
 338         print +($zzz == 4  && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
 339         $test++;
 340         print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
 341         $test++;
 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 # [perl #9728] used to dump core
 351 {
 352    $eval = eval 'sub { eval "sub { %S }" }';
 353    $eval->({});
 354    print "ok $test\n";
 355    $test++;
 356 }
 357
 358 # evals that appear in the DB package should see the lexical scope of the
 359 # thing outside DB that called them (usually the debugged code), rather
 360 # than the usual surrounding scope
 361
 362 $test=79;
 363 our $x = 1;
 364 {
 365     my $x=2;
 366     sub db1     { $x; eval '$x' }
 367     sub DB::db2 { $x; eval '$x' }
 368     package DB;
 369     sub db3     { eval '$x' }
 370     sub DB::db4 { eval '$x' }
 371     sub db5     { my $x=4; eval '$x' }
 372     package main;
 373     sub db6     { my $x=4; eval '$x' }
 374 }
 375 {
 376     my $x = 3;
 377     print db1()     == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
 378     print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
 379     print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
 380     print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
 381     print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
 382     print db6()     == 4 ? 'ok' : 'not ok', " $test\n"; $test++;
 383 }
 384 require './test.pl';
 385 $NO_ENDING = 1;
 386 # [perl #19022] used to end up with shared hash warnings
 387 # The program should generate no output, so anything we see is on stderr
 388 my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
 389                    stderr => 1);
 390
 391 if ($got eq '') {
 392   print "ok $test\n";
 393 } else {
 394   print "not ok $test\n";
 395   _diag ("# Got '$got'\n");
 396 }
 397 $test++;
 398
 399 # And a buggy way of fixing #19022 made this fail - $k became undef after the
 400 # eval for a build with copy on write
 401 {
 402   my %h;
 403   $h{a}=1;
 404   foreach my $k (keys %h) {
 405     if (defined $k and $k eq 'a') {
 406       print "ok $test\n";
 407     } else {
 408       print "not $test # got ", _q ($k), "\n";
 409     }
 410     $test++;
 411
 412     eval "\$k";
 413
 414     if (defined $k and $k eq 'a') {
 415       print "ok $test\n";
 416     } else {
 417       print "not $test # got ", _q ($k), "\n";
 418     }
 419     $test++;
 420   }
 421 }
 422
 423 sub Foo {} print Foo(eval {});
 424 print "ok ",$test++," - #20798 (used to dump core)\n";
 425
 426 # check for context in string eval
 427 {
 428   my(@r,$r,$c);
 429   sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
 430
 431   my $code = q{ context() };
 432   @r = qw( a b );
 433   $r = 'ab';
 434   @r = eval $code;
 435   print "@r$c" eq 'AA' ? "ok " : "# '@r$c' ne 'AA'\nnot ok ", $test++, "\n";
 436   $r = eval $code;
 437   print "$r$c" eq 'SS' ? "ok " : "# '$r$c' ne 'SS'\nnot ok ", $test++, "\n";
 438   eval $code;
 439   print   $c   eq 'V'  ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n";
 440 }
 441
 442 # [perl #34682] escaping an eval with last could coredump or dup output
 443
 444 $got = runperl (
 445     prog =>
 446     'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
 447 stderr => 1);
 448
 449 print "not " unless $got eq "ok\n";
 450 print "ok $test - eval and last\n"; $test++;
 451