| 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 | |