Commit | Line | Data |
a559c259 |
1 | #!./perl |
2 | |
7e736055 |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
1c25d394 |
6 | require './test.pl'; |
7e736055 |
7 | } |
8 | |
fa13de94 |
9 | print "1..99\n"; |
a559c259 |
10 | |
11 | eval 'print "ok 1\n";'; |
12 | |
13 | if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";} |
14 | |
15 | eval "\$foo\n = # this is a comment\n'ok 3';"; |
16 | print $foo,"\n"; |
17 | |
18 | eval "\$foo\n = # this is a comment\n'ok 4\n';"; |
19 | print $foo; |
20 | |
378cc40b |
21 | print eval ' |
79072805 |
22 | $foo =;'; # this tests for a call through yyerror() |
a559c259 |
23 | if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";} |
24 | |
378cc40b |
25 | print eval '$foo = /'; # this tests for a call through fatal() |
a559c259 |
26 | if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";} |
378cc40b |
27 | |
28 | print eval '"ok 7\n";'; |
29 | |
30 | # calculate a factorial with recursive evals |
31 | |
32 | $foo = 5; |
33 | $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}'; |
34 | $ans = eval $fact; |
35 | if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";} |
36 | |
37 | $foo = 5; |
a687059c |
38 | $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; |
378cc40b |
39 | $ans = eval $fact; |
40 | if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";} |
41 | |
1c25d394 |
42 | my $tempfile = tempfile(); |
43 | open(try,'>',$tempfile); |
44 | print try 'print "ok 10\n";',"\n"; |
378cc40b |
45 | close try; |
46 | |
1c25d394 |
47 | do "./$tempfile"; print $@; |
99b89507 |
48 | |
49 | # Test the singlequoted eval optimizer |
50 | |
51 | $i = 11; |
52 | for (1..3) { |
53 | eval 'print "ok ", $i++, "\n"'; |
54 | } |
55 | |
56 | eval { |
57 | print "ok 14\n"; |
58 | die "ok 16\n"; |
59 | 1; |
60 | } || print "ok 15\n$@"; |
61 | |
c7cc6f1c |
62 | # check whether eval EXPR determines value of EXPR correctly |
63 | |
64 | { |
65 | my @a = qw(a b c d); |
66 | my @b = eval @a; |
67 | print "@b" eq '4' ? "ok 17\n" : "not ok 17\n"; |
68 | print $@ ? "not ok 18\n" : "ok 18\n"; |
69 | |
70 | my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')]; |
71 | my $b; |
72 | @a = eval $a; |
73 | print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n"; |
74 | print $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n"; |
75 | $_ = eval $a; |
76 | print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n"; |
77 | eval $a; |
78 | print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n"; |
fc360e46 |
79 | |
80 | $b = 'wrong'; |
81 | $x = sub { |
82 | my $b = "right"; |
83 | print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n"; |
84 | }; |
85 | &$x(); |
c7cc6f1c |
86 | } |
155fc61f |
87 | |
88 | my $b = 'wrong'; |
89 | my $X = sub { |
90 | my $b = "right"; |
91 | print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n"; |
92 | }; |
93 | &$X(); |
94 | |
95 | |
96 | # check navigation of multiple eval boundaries to find lexicals |
97 | |
98 | my $x = 25; |
99 | eval <<'EOT'; die if $@; |
0a00efa0 |
100 | print "# $x\n"; # clone into eval's pad |
101 | sub do_eval1 { |
155fc61f |
102 | eval $_[0]; die if $@; |
103 | } |
104 | EOT |
0a00efa0 |
105 | do_eval1('print "ok $x\n"'); |
155fc61f |
106 | $x++; |
0a00efa0 |
107 | do_eval1('eval q[print "ok $x\n"]'); |
155fc61f |
108 | $x++; |
b318f128 |
109 | do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()'); |
0a00efa0 |
110 | $x++; |
111 | |
112 | # calls from within eval'' should clone outer lexicals |
113 | |
114 | eval <<'EOT'; die if $@; |
115 | sub do_eval2 { |
116 | eval $_[0]; die if $@; |
117 | } |
118 | do_eval2('print "ok $x\n"'); |
119 | $x++; |
120 | do_eval2('eval q[print "ok $x\n"]'); |
121 | $x++; |
b318f128 |
122 | do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()'); |
0a00efa0 |
123 | $x++; |
124 | EOT |
125 | |
126 | # calls outside eval'' should NOT clone lexicals from called context |
127 | |
a3985cdc |
128 | $main::ok = 'not ok'; |
129 | my $ok = 'ok'; |
0a00efa0 |
130 | eval <<'EOT'; die if $@; |
131 | # $x unbound here |
132 | sub do_eval3 { |
133 | eval $_[0]; die if $@; |
134 | } |
135 | EOT |
a3985cdc |
136 | { |
137 | my $ok = 'not ok'; |
138 | do_eval3('print "$ok ' . $x++ . '\n"'); |
139 | do_eval3('eval q[print "$ok ' . $x++ . '\n"]'); |
140 | do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()'); |
141 | } |
6b35e009 |
142 | |
143 | # can recursive subroutine-call inside eval'' see its own lexicals? |
144 | sub recurse { |
145 | my $l = shift; |
146 | if ($l < $x) { |
147 | ++$l; |
148 | eval 'print "# level $l\n"; recurse($l);'; |
149 | die if $@; |
150 | } |
151 | else { |
152 | print "ok $l\n"; |
153 | } |
154 | } |
155 | { |
156 | local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ }; |
157 | recurse($x-5); |
158 | } |
33b8ce05 |
159 | $x++; |
160 | |
161 | # do closures created within eval bind correctly? |
162 | eval <<'EOT'; |
163 | sub create_closure { |
164 | my $self = shift; |
165 | return sub { |
166 | print $self; |
167 | }; |
168 | } |
169 | EOT |
170 | create_closure("ok $x\n")->(); |
2680586e |
171 | $x++; |
172 | |
173 | # does lexical search terminate correctly at subroutine boundary? |
174 | $main::r = "ok $x\n"; |
175 | sub terminal { eval 'print $r' } |
176 | { |
177 | my $r = "not ok $x\n"; |
178 | eval 'terminal($r)'; |
179 | } |
180 | $x++; |
181 | |
a7c6d244 |
182 | # Have we cured panic which occurred with require/eval in die handler ? |
183 | $SIG{__DIE__} = sub { eval {1}; die shift }; |
184 | eval { die "ok ".$x++,"\n" }; |
185 | print $@; |
186 | |
a7ec2b44 |
187 | # does scalar eval"" pop stack correctly? |
188 | { |
189 | my $c = eval "(1,2)x10"; |
190 | print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n"; |
191 | $x++; |
192 | } |
b45de488 |
193 | |
194 | # return from eval {} should clear $@ correctly |
195 | { |
196 | my $status = eval { |
197 | eval { die }; |
198 | print "# eval { return } test\n"; |
199 | return; # removing this changes behavior |
200 | }; |
201 | print "not " if $@; |
202 | print "ok $x\n"; |
203 | $x++; |
204 | } |
205 | |
206 | # ditto for eval "" |
207 | { |
208 | my $status = eval q{ |
209 | eval q{ die }; |
210 | print "# eval q{ return } test\n"; |
211 | return; # removing this changes behavior |
212 | }; |
213 | print "not " if $@; |
214 | print "ok $x\n"; |
215 | $x++; |
216 | } |
3b2447bc |
217 | |
218 | # Check that eval catches bad goto calls |
219 | # (BUG ID 20010305.003) |
220 | { |
221 | eval { |
222 | eval { goto foo; }; |
223 | print ($@ ? "ok 41\n" : "not ok 41\n"); |
224 | last; |
225 | foreach my $i (1) { |
226 | foo: print "not ok 41\n"; |
227 | print "# jumped into foreach\n"; |
228 | } |
229 | }; |
230 | print "not ok 41\n" if $@; |
231 | } |
b6512f48 |
232 | |
233 | # Make sure that "my $$x" is forbidden |
234 | # 20011224 MJD |
235 | { |
236 | eval q{my $$x}; |
237 | print $@ ? "ok 42\n" : "not ok 42\n"; |
238 | eval q{my @$x}; |
239 | print $@ ? "ok 43\n" : "not ok 43\n"; |
240 | eval q{my %$x}; |
241 | print $@ ? "ok 44\n" : "not ok 44\n"; |
242 | eval q{my $$$x}; |
243 | print $@ ? "ok 45\n" : "not ok 45\n"; |
244 | } |
16a5162e |
245 | |
246 | # [ID 20020623.002] eval "" doesn't clear $@ |
247 | { |
248 | $@ = 5; |
249 | eval q{}; |
250 | print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n"; |
251 | } |
a3985cdc |
252 | |
253 | # DAPM Nov-2002. Perl should now capture the full lexical context during |
254 | # evals. |
255 | |
256 | $::zzz = $::zzz = 0; |
257 | my $zzz = 1; |
258 | |
259 | eval q{ |
260 | sub fred1 { |
261 | eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"} |
262 | } |
263 | fred1(47); |
264 | { my $zzz = 2; fred1(48) } |
265 | }; |
266 | |
267 | eval q{ |
268 | sub fred2 { |
269 | print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n"; |
270 | } |
271 | }; |
272 | fred2(49); |
273 | { my $zzz = 2; fred2(50) } |
274 | |
275 | # sort() starts a new context stack. Make sure we can still find |
276 | # the lexically enclosing sub |
277 | |
278 | sub do_sort { |
279 | my $zzz = 2; |
280 | my @a = sort |
281 | { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b } |
282 | 2, 1; |
283 | } |
284 | do_sort(); |
285 | |
286 | # more recursion and lexical scope leak tests |
287 | |
288 | eval q{ |
289 | my $r = -1; |
290 | my $yyy = 9; |
291 | sub fred3 { |
292 | my $l = shift; |
293 | my $r = -2; |
294 | return 1 if $l < 1; |
295 | return 0 if eval '$zzz' != 1; |
296 | return 0 if $yyy != 9; |
297 | return 0 if eval '$yyy' != 9; |
298 | return 0 if eval '$l' != $l; |
299 | return $l * fred3($l-1); |
300 | } |
301 | my $r = fred3(5); |
302 | print $r == 120 ? 'ok' : 'not ok', " 52\n"; |
303 | $r = eval'fred3(5)'; |
304 | print $r == 120 ? 'ok' : 'not ok', " 53\n"; |
305 | $r = 0; |
306 | eval '$r = fred3(5)'; |
307 | print $r == 120 ? 'ok' : 'not ok', " 54\n"; |
308 | $r = 0; |
309 | { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; |
310 | print $r == 120 ? 'ok' : 'not ok', " 55\n"; |
311 | }; |
312 | my $r = fred3(5); |
313 | print $r == 120 ? 'ok' : 'not ok', " 56\n"; |
314 | $r = eval'fred3(5)'; |
315 | print $r == 120 ? 'ok' : 'not ok', " 57\n"; |
316 | $r = 0; |
317 | eval'$r = fred3(5)'; |
318 | print $r == 120 ? 'ok' : 'not ok', " 58\n"; |
319 | $r = 0; |
320 | { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; |
321 | print $r == 120 ? 'ok' : 'not ok', " 59\n"; |
322 | |
323 | # check that goto &sub within evals doesn't leak lexical scope |
324 | |
325 | my $yyy = 2; |
326 | |
327 | my $test = 60; |
328 | sub fred4 { |
329 | my $zzz = 3; |
330 | print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n"; |
331 | $test++; |
332 | print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n"; |
333 | $test++; |
334 | } |
335 | |
336 | eval q{ |
337 | fred4(); |
338 | sub fred5 { |
339 | my $zzz = 4; |
340 | print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n"; |
341 | $test++; |
342 | print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n"; |
343 | $test++; |
344 | goto &fred4; |
345 | } |
346 | fred5(); |
347 | }; |
348 | fred5(); |
349 | { my $yyy = 88; my $zzz = 99; fred5(); } |
e8cf733a |
350 | eval q{ my $yyy = 888; my $zzz = 999; fred5(); }; |
a3985cdc |
351 | |
e8cf733a |
352 | # [perl #9728] used to dump core |
353 | { |
354 | $eval = eval 'sub { eval "sub { %S }" }'; |
355 | $eval->({}); |
7e736055 |
356 | print "ok $test\n"; |
357 | $test++; |
e8cf733a |
358 | } |
a3985cdc |
359 | |
d819b83a |
360 | # evals that appear in the DB package should see the lexical scope of the |
361 | # thing outside DB that called them (usually the debugged code), rather |
362 | # than the usual surrounding scope |
363 | |
364 | $test=79; |
365 | our $x = 1; |
366 | { |
367 | my $x=2; |
368 | sub db1 { $x; eval '$x' } |
369 | sub DB::db2 { $x; eval '$x' } |
370 | package DB; |
371 | sub db3 { eval '$x' } |
372 | sub DB::db4 { eval '$x' } |
373 | sub db5 { my $x=4; eval '$x' } |
374 | package main; |
375 | sub db6 { my $x=4; eval '$x' } |
376 | } |
377 | { |
378 | my $x = 3; |
379 | print db1() == 2 ? 'ok' : 'not ok', " $test\n"; $test++; |
380 | print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++; |
381 | print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++; |
382 | print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++; |
383 | print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++; |
384 | print db6() == 4 ? 'ok' : 'not ok', " $test\n"; $test++; |
385 | } |
7e736055 |
386 | require './test.pl'; |
387 | $NO_ENDING = 1; |
388 | # [perl #19022] used to end up with shared hash warnings |
389 | # The program should generate no output, so anything we see is on stderr |
390 | my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}', |
391 | stderr => 1); |
392 | |
393 | if ($got eq '') { |
394 | print "ok $test\n"; |
395 | } else { |
396 | print "not ok $test\n"; |
397 | _diag ("# Got '$got'\n"); |
398 | } |
399 | $test++; |
400 | |
401 | # And a buggy way of fixing #19022 made this fail - $k became undef after the |
402 | # eval for a build with copy on write |
403 | { |
404 | my %h; |
405 | $h{a}=1; |
406 | foreach my $k (keys %h) { |
407 | if (defined $k and $k eq 'a') { |
408 | print "ok $test\n"; |
409 | } else { |
410 | print "not $test # got ", _q ($k), "\n"; |
411 | } |
412 | $test++; |
413 | |
414 | eval "\$k"; |
415 | |
416 | if (defined $k and $k eq 'a') { |
417 | print "ok $test\n"; |
418 | } else { |
419 | print "not $test # got ", _q ($k), "\n"; |
420 | } |
421 | $test++; |
422 | } |
423 | } |
77d32bb7 |
424 | |
425 | sub Foo {} print Foo(eval {}); |
426 | print "ok ",$test++," - #20798 (used to dump core)\n"; |
f48583aa |
427 | |
428 | # check for context in string eval |
429 | { |
430 | my(@r,$r,$c); |
431 | sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') } |
432 | |
433 | my $code = q{ context() }; |
434 | @r = qw( a b ); |
435 | $r = 'ab'; |
436 | @r = eval $code; |
437 | print "@r$c" eq 'AA' ? "ok " : "# '@r$c' ne 'AA'\nnot ok ", $test++, "\n"; |
438 | $r = eval $code; |
439 | print "$r$c" eq 'SS' ? "ok " : "# '$r$c' ne 'SS'\nnot ok ", $test++, "\n"; |
440 | eval $code; |
441 | print $c eq 'V' ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n"; |
442 | } |
6ab4a6ff |
443 | |
444 | # [perl #34682] escaping an eval with last could coredump or dup output |
445 | |
446 | $got = runperl ( |
447 | prog => |
448 | 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)', |
449 | stderr => 1); |
450 | |
451 | print "not " unless $got eq "ok\n"; |
452 | print "ok $test - eval and last\n"; $test++; |
453 | |
eb034824 |
454 | # eval undef should be the same as eval "" barring any warnings |
455 | |
456 | { |
457 | local $@ = "foo"; |
458 | eval undef; |
459 | print "not " unless $@ eq ""; |
500960a6 |
460 | print "ok $test # eval undef \n"; $test++; |
461 | } |
462 | |
463 | { |
464 | no warnings; |
465 | eval "/ /a;"; |
466 | print "not " unless $@ =~ /^syntax error/; |
467 | print "ok $test # eval syntax error, no warnings \n"; $test++; |
eb034824 |
468 | } |
469 | |
410be5db |
470 | |
471 | # a syntax error in an eval called magically 9eg vie tie or overload) |
472 | # resulted in an assertion failure in S_docatch, since doeval had already |
473 | # poppedthe EVAL context due to the failure, but S_docatch expected the |
474 | # context to still be there. |
475 | |
476 | { |
477 | my $ok = 0; |
478 | package Eval1; |
479 | sub STORE { eval '('; $ok = 1 } |
480 | sub TIESCALAR { bless [] } |
481 | |
482 | my $x; |
483 | tie $x, bless []; |
484 | $x = 1; |
485 | print "not " unless $ok; |
486 | print "ok $test # eval docatch \n"; $test++; |
487 | } |
488 | |
489 | |
8433848b |
490 | # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset |
491 | # length $@ |
492 | $@ = ""; |
493 | eval { die "\x{a10d}"; }; |
494 | $_ = length $@; |
495 | eval { 1 }; |
496 | |
497 | print "not " if ($@ ne ""); |
498 | print "ok $test # length of \$@ after eval\n"; $test++; |
499 | |
500 | print "not " if (length $@ != 0); |
501 | print "ok $test # length of \$@ after eval\n"; $test++; |
502 | |
503 | # Check if eval { 1 }; compeltly resets $@ |
504 | if (eval "use Devel::Peek; 1;") { |
1c25d394 |
505 | $tempfile = tempfile(); |
506 | $outfile = tempfile(); |
507 | open PROG, ">", $tempfile or die "Can't create test file"; |
508 | my $prog = <<'END_EVAL_TEST'; |
8433848b |
509 | use Devel::Peek; |
510 | $! = 0; |
511 | $@ = $!; |
512 | my $ok = 0; |
513 | open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; |
1c25d394 |
514 | if (open(OUT, '>', '@@@@')) { |
8433848b |
515 | open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; |
516 | Dump($@); |
517 | print STDERR "******\n"; |
518 | eval { die "\x{a10d}"; }; |
519 | $_ = length $@; |
520 | eval { 1 }; |
521 | Dump($@); |
522 | open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; |
523 | close(OUT); |
1c25d394 |
524 | if (open(IN, '<', '@@@@')) { |
8433848b |
525 | local $/; |
526 | my $in = <IN>; |
527 | my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2); |
528 | $first =~ s/,pNOK//; |
529 | $ok = 1 if ($first eq $second); |
530 | } |
531 | } |
532 | |
533 | print $ok; |
8433848b |
534 | END_EVAL_TEST |
1c25d394 |
535 | $prog =~ s/\@\@\@\@/$outfile/g; |
536 | print PROG $prog; |
8433848b |
537 | close PROG; |
538 | |
1c25d394 |
539 | my $ok = runperl(progfile => $tempfile); |
8433848b |
540 | print "not " unless $ok; |
541 | print "ok $test # eval { 1 } completly resets \$@\n"; |
8433848b |
542 | } |
543 | else { |
5a1562d6 |
544 | print "ok $test # skipped - eval { 1 } completly resets \$@\n"; |
8433848b |
545 | } |
fa13de94 |
546 | $test++; |
410be5db |
547 | |
fa13de94 |
548 | # Test that "use feature" and other hint transmission in evals and s///ee |
549 | # don't leak memory |
550 | { |
551 | use feature qw(:5.10); |
e8514a9e |
552 | my $count_expected = ($^H & 0x20000) ? 2 : 1; |
fa13de94 |
553 | my $t; |
554 | my $s = "a"; |
555 | $s =~ s/a/$t = \%^H; qq( qq() );/ee; |
e8514a9e |
556 | print "not " if Internals::SvREFCNT(%$t) != $count_expected; |
fa13de94 |
557 | print "ok $test - RT 63110\n"; |
558 | $test++; |
559 | } |