5 eval 'print "ok 1\n";';
7 if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
9 eval "\$foo\n = # this is a comment\n'ok 3';";
12 eval "\$foo\n = # this is a comment\n'ok 4\n';";
16 $foo =;'; # this tests for a call through yyerror()
17 if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
19 print eval '$foo = /'; # this tests for a call through fatal()
20 if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
22 print eval '"ok 7\n";';
24 # calculate a factorial with recursive evals
27 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
29 if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
32 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
34 if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
37 print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
40 do './Op.eval'; print $@;
42 # Test the singlequoted eval optimizer
46 eval 'print "ok ", $i++, "\n"';
53 } || print "ok 15\n$@";
55 # check whether eval EXPR determines value of EXPR correctly
60 print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
61 print $@ ? "not ok 18\n" : "ok 18\n";
63 my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
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";
69 print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
71 print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
76 print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
84 print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
89 # check navigation of multiple eval boundaries to find lexicals
92 eval <<'EOT'; die if $@;
93 print "# $x\n"; # clone into eval's pad
95 eval $_[0]; die if $@;
98 do_eval1('print "ok $x\n"');
100 do_eval1('eval q[print "ok $x\n"]');
102 do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
105 # calls from within eval'' should clone outer lexicals
107 eval <<'EOT'; die if $@;
109 eval $_[0]; die if $@;
111 do_eval2('print "ok $x\n"');
113 do_eval2('eval q[print "ok $x\n"]');
115 do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
119 # calls outside eval'' should NOT clone lexicals from called context
121 $main::ok = 'not ok';
123 eval <<'EOT'; die if $@;
126 eval $_[0]; die if $@;
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"] }->()');
136 # can recursive subroutine-call inside eval'' see its own lexicals?
141 eval 'print "# level $l\n"; recurse($l);';
149 local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
154 # do closures created within eval bind correctly?
163 create_closure("ok $x\n")->();
166 # does lexical search terminate correctly at subroutine boundary?
167 $main::r = "ok $x\n";
168 sub terminal { eval 'print $r' }
170 my $r = "not ok $x\n";
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" };
180 # does scalar eval"" pop stack correctly?
182 my $c = eval "(1,2)x10";
183 print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
187 # return from eval {} should clear $@ correctly
191 print "# eval { return } test\n";
192 return; # removing this changes behavior
203 print "# eval q{ return } test\n";
204 return; # removing this changes behavior
211 # Check that eval catches bad goto calls
212 # (BUG ID 20010305.003)
216 print ($@ ? "ok 41\n" : "not ok 41\n");
219 foo: print "not ok 41\n";
220 print "# jumped into foreach\n";
223 print "not ok 41\n" if $@;
226 # Make sure that "my $$x" is forbidden
230 print $@ ? "ok 42\n" : "not ok 42\n";
232 print $@ ? "ok 43\n" : "not ok 43\n";
234 print $@ ? "ok 44\n" : "not ok 44\n";
236 print $@ ? "ok 45\n" : "not ok 45\n";
239 # [ID 20020623.002] eval "" doesn't clear $@
243 print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
246 # DAPM Nov-2002. Perl should now capture the full lexical context during
254 eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
257 { my $zzz = 2; fred1(48) }
262 print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
266 { my $zzz = 2; fred2(50) }
268 # sort() starts a new context stack. Make sure we can still find
269 # the lexically enclosing sub
274 { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
279 # more recursion and lexical scope leak tests
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);
295 print $r == 120 ? 'ok' : 'not ok', " 52\n";
297 print $r == 120 ? 'ok' : 'not ok', " 53\n";
299 eval '$r = fred3(5)';
300 print $r == 120 ? 'ok' : 'not ok', " 54\n";
302 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
303 print $r == 120 ? 'ok' : 'not ok', " 55\n";
306 print $r == 120 ? 'ok' : 'not ok', " 56\n";
308 print $r == 120 ? 'ok' : 'not ok', " 57\n";
311 print $r == 120 ? 'ok' : 'not ok', " 58\n";
313 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
314 print $r == 120 ? 'ok' : 'not ok', " 59\n";
316 # check that goto &sub within evals doesn't leak lexical scope
323 print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
325 print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
333 print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
335 print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
342 { my $yyy = 88; my $zzz = 99; fred5(); }
343 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
345 # [perl #9728] used to dump core
347 $eval = eval 'sub { eval "sub { %S }" }';
352 # evals that appear in the DB package should see the lexical scope of the
353 # thing outside DB that called them (usually the debugged code), rather
354 # than the usual surrounding scope
360 sub db1 { $x; eval '$x' }
361 sub DB::db2 { $x; eval '$x' }
363 sub db3 { eval '$x' }
364 sub DB::db4 { eval '$x' }
365 sub db5 { my $x=4; eval '$x' }
367 sub db6 { my $x=4; eval '$x' }
371 print db1() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
372 print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
373 print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
374 print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
375 print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
376 print db6() == 4 ? 'ok' : 'not ok', " $test\n"; $test++;