10 eval 'print "ok 1\n";';
12 if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
14 eval "\$foo\n = # this is a comment\n'ok 3';";
17 eval "\$foo\n = # this is a comment\n'ok 4\n';";
21 $foo =;'; # this tests for a call through yyerror()
22 if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
24 print eval '$foo = /'; # this tests for a call through fatal()
25 if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
27 print eval '"ok 7\n";';
29 # calculate a factorial with recursive evals
32 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
34 if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
37 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
39 if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
42 print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
45 do './Op.eval'; print $@;
47 # Test the singlequoted eval optimizer
51 eval 'print "ok ", $i++, "\n"';
58 } || print "ok 15\n$@";
60 # check whether eval EXPR determines value of EXPR correctly
65 print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
66 print $@ ? "not ok 18\n" : "ok 18\n";
68 my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
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";
74 print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
76 print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
81 print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
89 print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
94 # check navigation of multiple eval boundaries to find lexicals
97 eval <<'EOT'; die if $@;
98 print "# $x\n"; # clone into eval's pad
100 eval $_[0]; die if $@;
103 do_eval1('print "ok $x\n"');
105 do_eval1('eval q[print "ok $x\n"]');
107 do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
110 # calls from within eval'' should clone outer lexicals
112 eval <<'EOT'; die if $@;
114 eval $_[0]; die if $@;
116 do_eval2('print "ok $x\n"');
118 do_eval2('eval q[print "ok $x\n"]');
120 do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
124 # calls outside eval'' should NOT clone lexicals from called context
126 $main::ok = 'not ok';
128 eval <<'EOT'; die if $@;
131 eval $_[0]; die if $@;
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"] }->()');
141 # can recursive subroutine-call inside eval'' see its own lexicals?
146 eval 'print "# level $l\n"; recurse($l);';
154 local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
159 # do closures created within eval bind correctly?
168 create_closure("ok $x\n")->();
171 # does lexical search terminate correctly at subroutine boundary?
172 $main::r = "ok $x\n";
173 sub terminal { eval 'print $r' }
175 my $r = "not ok $x\n";
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" };
185 # does scalar eval"" pop stack correctly?
187 my $c = eval "(1,2)x10";
188 print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
192 # return from eval {} should clear $@ correctly
196 print "# eval { return } test\n";
197 return; # removing this changes behavior
208 print "# eval q{ return } test\n";
209 return; # removing this changes behavior
216 # Check that eval catches bad goto calls
217 # (BUG ID 20010305.003)
221 print ($@ ? "ok 41\n" : "not ok 41\n");
224 foo: print "not ok 41\n";
225 print "# jumped into foreach\n";
228 print "not ok 41\n" if $@;
231 # Make sure that "my $$x" is forbidden
235 print $@ ? "ok 42\n" : "not ok 42\n";
237 print $@ ? "ok 43\n" : "not ok 43\n";
239 print $@ ? "ok 44\n" : "not ok 44\n";
241 print $@ ? "ok 45\n" : "not ok 45\n";
244 # [ID 20020623.002] eval "" doesn't clear $@
248 print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
251 # DAPM Nov-2002. Perl should now capture the full lexical context during
259 eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
262 { my $zzz = 2; fred1(48) }
267 print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
271 { my $zzz = 2; fred2(50) }
273 # sort() starts a new context stack. Make sure we can still find
274 # the lexically enclosing sub
279 { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
284 # more recursion and lexical scope leak tests
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);
300 print $r == 120 ? 'ok' : 'not ok', " 52\n";
302 print $r == 120 ? 'ok' : 'not ok', " 53\n";
304 eval '$r = fred3(5)';
305 print $r == 120 ? 'ok' : 'not ok', " 54\n";
307 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
308 print $r == 120 ? 'ok' : 'not ok', " 55\n";
311 print $r == 120 ? 'ok' : 'not ok', " 56\n";
313 print $r == 120 ? 'ok' : 'not ok', " 57\n";
316 print $r == 120 ? 'ok' : 'not ok', " 58\n";
318 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
319 print $r == 120 ? 'ok' : 'not ok', " 59\n";
321 # check that goto &sub within evals doesn't leak lexical scope
328 print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
330 print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
338 print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
340 print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
347 { my $yyy = 88; my $zzz = 99; fred5(); }
348 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
350 # [perl #9728] used to dump core
352 $eval = eval 'sub { eval "sub { %S }" }';
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
366 sub db1 { $x; eval '$x' }
367 sub DB::db2 { $x; eval '$x' }
369 sub db3 { eval '$x' }
370 sub DB::db4 { eval '$x' }
371 sub db5 { my $x=4; eval '$x' }
373 sub db6 { my $x=4; eval '$x' }
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++;
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}}',
394 print "not ok $test\n";
395 _diag ("# Got '$got'\n");
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
404 foreach my $k (keys %h) {
405 if (defined $k and $k eq 'a') {
408 print "not $test # got ", _q ($k), "\n";
414 if (defined $k and $k eq 'a') {
417 print "not $test # got ", _q ($k), "\n";
423 sub Foo {} print Foo(eval {});
424 print "ok ",$test++," - #20798 (used to dump core)\n";
426 # check for context in string eval
429 sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
431 my $code = q{ context() };
435 print "@r$c" eq 'AA' ? "ok " : "# '@r$c' ne 'AA'\nnot ok ", $test++, "\n";
437 print "$r$c" eq 'SS' ? "ok " : "# '$r$c' ne 'SS'\nnot ok ", $test++, "\n";
439 print $c eq 'V' ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n";