t/op/eval.t

   1 #!./perl
   2
   3 print "1..40\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 { 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 { 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::x = 'ok';
 122 eval <<'EOT'; die if $@;
 123   # $x unbound here
 124   sub do_eval3 {
 125      eval $_[0]; die if $@;
 126   }
 127 EOT
 128 do_eval3('print "$x ' . $x . '\n"');
 129 $x++;
 130 do_eval3('eval q[print "$x ' . $x . '\n"]');
 131 $x++;
 132 do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()');
 133 $x++;
 134
 135 # can recursive subroutine-call inside eval'' see its own lexicals?
 136 sub recurse {
 137   my $l = shift;
 138   if ($l < $x) {
 139      ++$l;
 140      eval 'print "# level $l\n"; recurse($l);';
 141      die if $@;
 142   }
 143   else {
 144     print "ok $l\n";
 145   }
 146 }
 147 {
 148   local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
 149   recurse($x-5);
 150 }
 151 $x++;
 152
 153 # do closures created within eval bind correctly?
 154 eval <<'EOT';
 155   sub create_closure {
 156     my $self = shift;
 157     return sub {
 158        print $self;
 159     };
 160   }
 161 EOT
 162 create_closure("ok $x\n")->();
 163 $x++;
 164
 165 # does lexical search terminate correctly at subroutine boundary?
 166 $main::r = "ok $x\n";
 167 sub terminal { eval 'print $r' }
 168 {
 169    my $r = "not ok $x\n";
 170    eval 'terminal($r)';
 171 }
 172 $x++;
 173
 174 # Have we cured panic which occurred with require/eval in die handler ?
 175 $SIG{__DIE__} = sub { eval {1}; die shift };
 176 eval { die "ok ".$x++,"\n" };
 177 print $@;
 178
 179 # does scalar eval"" pop stack correctly?
 180 {
 181     my $c = eval "(1,2)x10";
 182     print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
 183     $x++;
 184 }
 185
 186 # return from eval {} should clear $@ correctly
 187 {
 188     my $status = eval {
 189         eval { die };
 190         print "# eval { return } test\n";
 191         return; # removing this changes behavior
 192     };
 193     print "not " if $@;
 194     print "ok $x\n";
 195     $x++;
 196 }
 197
 198 # ditto for eval ""
 199 {
 200     my $status = eval q{
 201         eval q{ die };
 202         print "# eval q{ return } test\n";
 203         return; # removing this changes behavior
 204     };
 205     print "not " if $@;
 206     print "ok $x\n";
 207     $x++;
 208 }