This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
More documentation of obscure flags is good, even if the
[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}
a3985cdc
DM
245
246# DAPM Nov-2002. Perl should now capture the full lexical context during
247# evals.
248
249$::zzz = $::zzz = 0;
250my $zzz = 1;
251
252eval 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
260eval q{
261 sub fred2 {
262 print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
263 }
264};
265fred2(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
271sub 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}
277do_sort();
278
279# more recursion and lexical scope leak tests
280
281eval 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};
305my $r = fred3(5);
306print $r == 120 ? 'ok' : 'not ok', " 56\n";
307$r = eval'fred3(5)';
308print $r == 120 ? 'ok' : 'not ok', " 57\n";
309$r = 0;
310eval'$r = fred3(5)';
311print $r == 120 ? 'ok' : 'not ok', " 58\n";
312$r = 0;
313{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
314print $r == 120 ? 'ok' : 'not ok', " 59\n";
315
316# check that goto &sub within evals doesn't leak lexical scope
317
318my $yyy = 2;
319
320my $test = 60;
321sub 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
329eval 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};
341fred5();
342{ my $yyy = 88; my $zzz = 99; fred5(); }
e8cf733a 343eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
a3985cdc 344
e8cf733a
HS
345# [perl #9728] used to dump core
346{
347 $eval = eval 'sub { eval "sub { %S }" }';
348 $eval->({});
349 print "ok 78\n";
350}
a3985cdc 351