t/op/eval.t

   1 #!./perl
   2
   3 print "1..78\n";
   4
   5 eval 'print "ok 1\n";';
   6
   7 if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
   8
   9 eval "\$foo\n    = # this is a comment\n'ok 3';";
  10 print $foo,"\n";
  11
  12 eval "\$foo\n    = # this is a comment\n'ok 4\n';";
  13 print $foo;
  14
  15 print eval '
  16 $foo =;';               # this tests for a call through yyerror()
  17 if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
  18
  19 print eval '$foo = /';  # this tests for a call through fatal()
  20 if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
  21
  22 print eval '"ok 7\n";';
  23
  24 # calculate a factorial with recursive evals
  25
  26 $foo = 5;
  27 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
  28 $ans = eval $fact;
  29 if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
  30
  31 $foo = 5;
  32 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
  33 $ans = eval $fact;
  34 if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
  35
  36 open(try,'>Op.eval');
  37 print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
  38 close try;
  39
  40 do './Op.eval'; print $@;
  41
  42 # Test the singlequoted eval optimizer
  43
  44 $i = 11;
  45 for (1..3) {
  46     eval 'print "ok ", $i++, "\n"';
  47 }
  48
  49 eval {
  50     print "ok 14\n";
  51     die "ok 16\n";
  52     1;
  53 } || print "ok 15\n$@";
  54
  55 # check whether eval EXPR determines value of EXPR correctly
  56
  57 {
  58   my @a = qw(a b c d);
  59   my @b = eval @a;
  60   print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
  61   print $@ ? "not ok 18\n" : "ok 18\n";
  62
  63   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
  64   my $b;
  65   @a = eval $a;
  66   print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
  67   print   $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
  68   $_ = eval $a;
  69   print   $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
  70   eval $a;
  71   print   $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
  72
  73   $b = 'wrong';
  74   $x = sub {
  75      my $b = "right";
  76      print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
  77   };
  78   &$x();
  79 }
  80
  81 my $b = 'wrong';
  82 my $X = sub {
  83    my $b = "right";
  84    print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
  85 };
  86 &$X();
  87
  88
  89 # check navigation of multiple eval boundaries to find lexicals
  90
  91 my $x = 25;
  92 eval <<'EOT'; die if $@;
  93   print "# $x\n";       # clone into eval's pad
  94   sub do_eval1 {
  95      eval $_[0]; die if $@;
  96   }
  97 EOT
  98 do_eval1('print "ok $x\n"');
  99 $x++;
 100 do_eval1('eval q[print "ok $x\n"]');
 101 $x++;
 102 do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
 103 $x++;
 104
 105 # calls from within eval'' should clone outer lexicals
 106
 107 eval <<'EOT'; die if $@;
 108   sub do_eval2 {
 109      eval $_[0]; die if $@;
 110   }
 111 do_eval2('print "ok $x\n"');
 112 $x++;
 113 do_eval2('eval q[print "ok $x\n"]');
 114 $x++;
 115 do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
 116 $x++;
 117 EOT
 118
 119 # calls outside eval'' should NOT clone lexicals from called context
 120
 121 $main::ok = 'not ok';
 122 my $ok = 'ok';
 123 eval <<'EOT'; die if $@;
 124   # $x unbound here
 125   sub do_eval3 {
 126      eval $_[0]; die if $@;
 127   }
 128 EOT
 129 {
 130     my $ok = 'not ok';
 131     do_eval3('print "$ok ' . $x++ . '\n"');
 132     do_eval3('eval q[print "$ok ' . $x++ . '\n"]');
 133     do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()');
 134 }
 135
 136 # can recursive subroutine-call inside eval'' see its own lexicals?
 137 sub recurse {
 138   my $l = shift;
 139   if ($l < $x) {
 140      ++$l;
 141      eval 'print "# level $l\n"; recurse($l);';
 142      die if $@;
 143   }
 144   else {
 145     print "ok $l\n";
 146   }
 147 }
 148 {
 149   local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
 150   recurse($x-5);
 151 }
 152 $x++;
 153
 154 # do closures created within eval bind correctly?
 155 eval <<'EOT';
 156   sub create_closure {
 157     my $self = shift;
 158     return sub {
 159        print $self;
 160     };
 161   }
 162 EOT
 163 create_closure("ok $x\n")->();
 164 $x++;
 165
 166 # does lexical search terminate correctly at subroutine boundary?
 167 $main::r = "ok $x\n";
 168 sub terminal { eval 'print $r' }
 169 {
 170    my $r = "not ok $x\n";
 171    eval 'terminal($r)';
 172 }
 173 $x++;
 174
 175 # Have we cured panic which occurred with require/eval in die handler ?
 176 $SIG{__DIE__} = sub { eval {1}; die shift };
 177 eval { die "ok ".$x++,"\n" };
 178 print $@;
 179
 180 # does scalar eval"" pop stack correctly?
 181 {
 182     my $c = eval "(1,2)x10";
 183     print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
 184     $x++;
 185 }
 186
 187 # return from eval {} should clear $@ correctly
 188 {
 189     my $status = eval {
 190         eval { die };
 191         print "# eval { return } test\n";
 192         return; # removing this changes behavior
 193     };
 194     print "not " if $@;
 195     print "ok $x\n";
 196     $x++;
 197 }
 198
 199 # ditto for eval ""
 200 {
 201     my $status = eval q{
 202         eval q{ die };
 203         print "# eval q{ return } test\n";
 204         return; # removing this changes behavior
 205     };
 206     print "not " if $@;
 207     print "ok $x\n";
 208     $x++;
 209 }
 210
 211 # Check that eval catches bad goto calls
 212 #   (BUG ID 20010305.003)
 213 {
 214     eval {
 215         eval { goto foo; };
 216         print ($@ ? "ok 41\n" : "not ok 41\n");
 217         last;
 218         foreach my $i (1) {
 219             foo: print "not ok 41\n";
 220             print "# jumped into foreach\n";
 221         }
 222     };
 223     print "not ok 41\n" if $@;
 224 }
 225
 226 # Make sure that "my $$x" is forbidden
 227 # 20011224 MJD
 228 {
 229   eval q{my $$x};
 230   print $@ ? "ok 42\n" : "not ok 42\n";
 231   eval q{my @$x};
 232   print $@ ? "ok 43\n" : "not ok 43\n";
 233   eval q{my %$x};
 234   print $@ ? "ok 44\n" : "not ok 44\n";
 235   eval q{my $$$x};
 236   print $@ ? "ok 45\n" : "not ok 45\n";
 237 }
 238
 239 # [ID 20020623.002] eval "" doesn't clear $@
 240 {
 241     $@ = 5;
 242     eval q{};
 243     print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
 244 }
 245
 246 # DAPM Nov-2002. Perl should now capture the full lexical context during
 247 # evals.
 248
 249 $::zzz = $::zzz = 0;
 250 my $zzz = 1;
 251
 252 eval q{
 253     sub fred1 {
 254         eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
 255     }
 256     fred1(47);
 257     { my $zzz = 2; fred1(48) }
 258 };
 259
 260 eval q{
 261     sub fred2 {
 262         print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
 263     }
 264 };
 265 fred2(49);
 266 { my $zzz = 2; fred2(50) }
 267
 268 # sort() starts a new context stack. Make sure we can still find
 269 # the lexically enclosing sub
 270
 271 sub do_sort {
 272     my $zzz = 2;
 273     my @a = sort
 274             { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
 275             2, 1;
 276 }
 277 do_sort();
 278
 279 # more recursion and lexical scope leak tests
 280
 281 eval q{
 282     my $r = -1;
 283     my $yyy = 9;
 284     sub fred3 {
 285         my $l = shift;
 286         my $r = -2;
 287         return 1 if $l < 1;
 288         return 0 if eval '$zzz' != 1;
 289         return 0 if       $yyy  != 9;
 290         return 0 if eval '$yyy' != 9;
 291         return 0 if eval '$l' != $l;
 292         return $l * fred3($l-1);
 293     }
 294     my $r = fred3(5);
 295     print $r == 120 ? 'ok' : 'not ok', " 52\n";
 296     $r = eval'fred3(5)';
 297     print $r == 120 ? 'ok' : 'not ok', " 53\n";
 298     $r = 0;
 299     eval '$r = fred3(5)';
 300     print $r == 120 ? 'ok' : 'not ok', " 54\n";
 301     $r = 0;
 302     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
 303     print $r == 120 ? 'ok' : 'not ok', " 55\n";
 304 };
 305 my $r = fred3(5);
 306 print $r == 120 ? 'ok' : 'not ok', " 56\n";
 307 $r = eval'fred3(5)';
 308 print $r == 120 ? 'ok' : 'not ok', " 57\n";
 309 $r = 0;
 310 eval'$r = fred3(5)';
 311 print $r == 120 ? 'ok' : 'not ok', " 58\n";
 312 $r = 0;
 313 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
 314 print $r == 120 ? 'ok' : 'not ok', " 59\n";
 315
 316 # check that goto &sub within evals doesn't leak lexical scope
 317
 318 my $yyy = 2;
 319
 320 my $test = 60;
 321 sub fred4 {
 322     my $zzz = 3;
 323     print +($zzz == 3  && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
 324     $test++;
 325     print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
 326     $test++;
 327 }
 328
 329 eval q{
 330     fred4();
 331     sub fred5 {
 332         my $zzz = 4;
 333         print +($zzz == 4  && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
 334         $test++;
 335         print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
 336         $test++;
 337         goto &fred4;
 338     }
 339     fred5();
 340 };
 341 fred5();
 342 { my $yyy = 88; my $zzz = 99; fred5(); }
 343 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
 344
 345 # [perl #9728] used to dump core
 346 {
 347    $eval = eval 'sub { eval "sub { %S }" }';
 348    $eval->({});
 349    print "ok 78\n";
 350 }
 351