This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate 5.8-maint: changes #18174 18187 18189-92 18202 18209 18214-5
[perl5.git] / t / op / eval.t
CommitLineData
a559c259
LW
1#!./perl
2
6c8d78fb 3print "1..78\n";
a559c259
LW
4
5eval 'print "ok 1\n";';
6
7if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
8
9eval "\$foo\n = # this is a comment\n'ok 3';";
10print $foo,"\n";
11
12eval "\$foo\n = # this is a comment\n'ok 4\n';";
13print $foo;
14
378cc40b 15print eval '
79072805 16$foo =;'; # this tests for a call through yyerror()
a559c259
LW
17if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
18
378cc40b 19print eval '$foo = /'; # this tests for a call through fatal()
a559c259 20if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
378cc40b
LW
21
22print 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;
29if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
30
31$foo = 5;
a687059c 32$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
378cc40b
LW
33$ans = eval $fact;
34if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
35
36open(try,'>Op.eval');
37print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
38close try;
39
4343e7c3 40do './Op.eval'; print $@;
99b89507
LW
41
42# Test the singlequoted eval optimizer
43
44$i = 11;
45for (1..3) {
46 eval 'print "ok ", $i++, "\n"';
47}
48
49eval {
50 print "ok 14\n";
51 die "ok 16\n";
52 1;
53} || print "ok 15\n$@";
54
c7cc6f1c
GS
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";
fc360e46
AB
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();
c7cc6f1c 79}
155fc61f
GS
80
81my $b = 'wrong';
82my $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
91my $x = 25;
92eval <<'EOT'; die if $@;
0a00efa0
GS
93 print "# $x\n"; # clone into eval's pad
94 sub do_eval1 {
155fc61f
GS
95 eval $_[0]; die if $@;
96 }
97EOT
0a00efa0 98do_eval1('print "ok $x\n"');
155fc61f 99$x++;
0a00efa0 100do_eval1('eval q[print "ok $x\n"]');
155fc61f 101$x++;
b318f128 102do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0
GS
103$x++;
104
105# calls from within eval'' should clone outer lexicals
106
107eval <<'EOT'; die if $@;
108 sub do_eval2 {
109 eval $_[0]; die if $@;
110 }
111do_eval2('print "ok $x\n"');
112$x++;
113do_eval2('eval q[print "ok $x\n"]');
114$x++;
b318f128 115do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0
GS
116$x++;
117EOT
118
119# calls outside eval'' should NOT clone lexicals from called context
120
a3985cdc
DM
121$main::ok = 'not ok';
122my $ok = 'ok';
0a00efa0
GS
123eval <<'EOT'; die if $@;
124 # $x unbound here
125 sub do_eval3 {
126 eval $_[0]; die if $@;
127 }
128EOT
a3985cdc
DM
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}
6b35e009
GS
135
136# can recursive subroutine-call inside eval'' see its own lexicals?
137sub 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}
33b8ce05
GS
152$x++;
153
154# do closures created within eval bind correctly?
155eval <<'EOT';
156 sub create_closure {
157 my $self = shift;
158 return sub {
159 print $self;
160 };
161 }
162EOT
163create_closure("ok $x\n")->();
2680586e
GS
164$x++;
165
166# does lexical search terminate correctly at subroutine boundary?
167$main::r = "ok $x\n";
168sub terminal { eval 'print $r' }
169{
170 my $r = "not ok $x\n";
171 eval 'terminal($r)';
172}
173$x++;
174
a7c6d244
NIS
175# Have we cured panic which occurred with require/eval in die handler ?
176$SIG{__DIE__} = sub { eval {1}; die shift };
177eval { die "ok ".$x++,"\n" };
178print $@;
179
a7ec2b44
GS
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}
b45de488
GS
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}
3b2447bc
RH
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}
b6512f48
MJD
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}
16a5162e
JH
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}
6c8d78fb
HS
245# [perl #9728] used to dump core
246{
247 $eval = eval 'sub { eval "sub { %S }" }';
248 $eval->({});
249 print "ok 47\n";
250}
a3985cdc
DM
251
252# DAPM Nov-2002. Perl should now capture the full lexical context during
253# evals.
254
255$::zzz = $::zzz = 0;
256my $zzz = 1;
257
258eval q{
259 sub fred1 {
260 eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
261 }
262 fred1(47);
263 { my $zzz = 2; fred1(48) }
264};
265
266eval q{
267 sub fred2 {
268 print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
269 }
270};
271fred2(49);
272{ my $zzz = 2; fred2(50) }
273
274# sort() starts a new context stack. Make sure we can still find
275# the lexically enclosing sub
276
277sub do_sort {
278 my $zzz = 2;
279 my @a = sort
280 { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
281 2, 1;
282}
283do_sort();
284
285# more recursion and lexical scope leak tests
286
287eval q{
288 my $r = -1;
289 my $yyy = 9;
290 sub fred3 {
291 my $l = shift;
292 my $r = -2;
293 return 1 if $l < 1;
294 return 0 if eval '$zzz' != 1;
295 return 0 if $yyy != 9;
296 return 0 if eval '$yyy' != 9;
297 return 0 if eval '$l' != $l;
298 return $l * fred3($l-1);
299 }
300 my $r = fred3(5);
301 print $r == 120 ? 'ok' : 'not ok', " 52\n";
302 $r = eval'fred3(5)';
303 print $r == 120 ? 'ok' : 'not ok', " 53\n";
304 $r = 0;
305 eval '$r = fred3(5)';
306 print $r == 120 ? 'ok' : 'not ok', " 54\n";
307 $r = 0;
308 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
309 print $r == 120 ? 'ok' : 'not ok', " 55\n";
310};
311my $r = fred3(5);
312print $r == 120 ? 'ok' : 'not ok', " 56\n";
313$r = eval'fred3(5)';
314print $r == 120 ? 'ok' : 'not ok', " 57\n";
315$r = 0;
316eval'$r = fred3(5)';
317print $r == 120 ? 'ok' : 'not ok', " 58\n";
318$r = 0;
319{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
320print $r == 120 ? 'ok' : 'not ok', " 59\n";
321
322# check that goto &sub within evals doesn't leak lexical scope
323
324my $yyy = 2;
325
326my $test = 60;
327sub fred4 {
328 my $zzz = 3;
329 print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
330 $test++;
331 print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
332 $test++;
333}
334
335eval q{
336 fred4();
337 sub fred5 {
338 my $zzz = 4;
339 print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
340 $test++;
341 print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
342 $test++;
343 goto &fred4;
344 }
345 fred5();
346};
347fred5();
348{ my $yyy = 88; my $zzz = 99; fred5(); }
349eval q{ my $yyy = 888; my $zzz = 999; fred5(); }
350
351