Commit | Line | Data |
a559c259 |
1 | #!./perl |
2 | |
6c8d78fb |
3 | print "1..78\n"; |
a559c259 |
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 | |
378cc40b |
15 | print eval ' |
79072805 |
16 | $foo =;'; # this tests for a call through yyerror() |
a559c259 |
17 | if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";} |
18 | |
378cc40b |
19 | print eval '$foo = /'; # this tests for a call through fatal() |
a559c259 |
20 | if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";} |
378cc40b |
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; |
a687059c |
32 | $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; |
378cc40b |
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 | |
4343e7c3 |
40 | do './Op.eval'; print $@; |
99b89507 |
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 | |
c7cc6f1c |
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 |
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 |
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 $@; |
0a00efa0 |
93 | print "# $x\n"; # clone into eval's pad |
94 | sub do_eval1 { |
155fc61f |
95 | eval $_[0]; die if $@; |
96 | } |
97 | EOT |
0a00efa0 |
98 | do_eval1('print "ok $x\n"'); |
155fc61f |
99 | $x++; |
0a00efa0 |
100 | do_eval1('eval q[print "ok $x\n"]'); |
155fc61f |
101 | $x++; |
b318f128 |
102 | do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()'); |
0a00efa0 |
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++; |
b318f128 |
115 | do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()'); |
0a00efa0 |
116 | $x++; |
117 | EOT |
118 | |
119 | # calls outside eval'' should NOT clone lexicals from called context |
120 | |
a3985cdc |
121 | $main::ok = 'not ok'; |
122 | my $ok = 'ok'; |
0a00efa0 |
123 | eval <<'EOT'; die if $@; |
124 | # $x unbound here |
125 | sub do_eval3 { |
126 | eval $_[0]; die if $@; |
127 | } |
128 | EOT |
a3985cdc |
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 |
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 | } |
33b8ce05 |
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")->(); |
2680586e |
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 | |
a7c6d244 |
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 | |
a7ec2b44 |
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 |
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 |
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 |
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 |
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 |
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(); } |
e8cf733a |
343 | eval q{ my $yyy = 888; my $zzz = 999; fred5(); }; |
a3985cdc |
344 | |
e8cf733a |
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 | |