This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8_heavy.pl: Use CORE:: case function overridden
[perl5.git] / t / op / eval.t
CommitLineData
a559c259
LW
1#!./perl
2
7e736055
HS
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
1c25d394 6 require './test.pl';
7e736055
HS
7}
8
3aadd5cd 9print "1..108\n";
a559c259
LW
10
11eval 'print "ok 1\n";';
12
13if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
14
15eval "\$foo\n = # this is a comment\n'ok 3';";
16print $foo,"\n";
17
18eval "\$foo\n = # this is a comment\n'ok 4\n';";
19print $foo;
20
378cc40b 21print eval '
79072805 22$foo =;'; # this tests for a call through yyerror()
a559c259
LW
23if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
24
378cc40b 25print eval '$foo = /'; # this tests for a call through fatal()
a559c259 26if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
378cc40b
LW
27
28print 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;
35if ($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
LW
39$ans = eval $fact;
40if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
41
1c25d394
NC
42my $tempfile = tempfile();
43open(try,'>',$tempfile);
44print try 'print "ok 10\n";',"\n";
378cc40b
LW
45close try;
46
1c25d394 47do "./$tempfile"; print $@;
99b89507
LW
48
49# Test the singlequoted eval optimizer
50
51$i = 11;
52for (1..3) {
53 eval 'print "ok ", $i++, "\n"';
54}
55
56eval {
57 print "ok 14\n";
58 die "ok 16\n";
59 1;
60} || print "ok 15\n$@";
61
c7cc6f1c
GS
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
AB
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
GS
87
88my $b = 'wrong';
89my $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
98my $x = 25;
99eval <<'EOT'; die if $@;
0a00efa0
GS
100 print "# $x\n"; # clone into eval's pad
101 sub do_eval1 {
155fc61f
GS
102 eval $_[0]; die if $@;
103 }
104EOT
0a00efa0 105do_eval1('print "ok $x\n"');
155fc61f 106$x++;
0a00efa0 107do_eval1('eval q[print "ok $x\n"]');
155fc61f 108$x++;
b318f128 109do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0
GS
110$x++;
111
112# calls from within eval'' should clone outer lexicals
113
114eval <<'EOT'; die if $@;
115 sub do_eval2 {
116 eval $_[0]; die if $@;
117 }
118do_eval2('print "ok $x\n"');
119$x++;
120do_eval2('eval q[print "ok $x\n"]');
121$x++;
b318f128 122do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0
GS
123$x++;
124EOT
125
126# calls outside eval'' should NOT clone lexicals from called context
127
a3985cdc
DM
128$main::ok = 'not ok';
129my $ok = 'ok';
0a00efa0
GS
130eval <<'EOT'; die if $@;
131 # $x unbound here
132 sub do_eval3 {
133 eval $_[0]; die if $@;
134 }
135EOT
a3985cdc
DM
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
GS
142
143# can recursive subroutine-call inside eval'' see its own lexicals?
144sub 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
GS
159$x++;
160
161# do closures created within eval bind correctly?
162eval <<'EOT';
163 sub create_closure {
164 my $self = shift;
165 return sub {
166 print $self;
167 };
168 }
169EOT
170create_closure("ok $x\n")->();
2680586e
GS
171$x++;
172
173# does lexical search terminate correctly at subroutine boundary?
174$main::r = "ok $x\n";
175sub terminal { eval 'print $r' }
176{
177 my $r = "not ok $x\n";
178 eval 'terminal($r)';
179}
180$x++;
181
a7c6d244
NIS
182# Have we cured panic which occurred with require/eval in die handler ?
183$SIG{__DIE__} = sub { eval {1}; die shift };
184eval { die "ok ".$x++,"\n" };
185print $@;
186
a7ec2b44
GS
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
GS
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
RH
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
MJD
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
JH
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
DM
252
253# DAPM Nov-2002. Perl should now capture the full lexical context during
254# evals.
255
256$::zzz = $::zzz = 0;
257my $zzz = 1;
258
259eval 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
267eval q{
268 sub fred2 {
269 print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
270 }
271};
272fred2(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
278sub 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}
284do_sort();
285
286# more recursion and lexical scope leak tests
287
288eval 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};
312my $r = fred3(5);
313print $r == 120 ? 'ok' : 'not ok', " 56\n";
314$r = eval'fred3(5)';
315print $r == 120 ? 'ok' : 'not ok', " 57\n";
316$r = 0;
317eval'$r = fred3(5)';
318print $r == 120 ? 'ok' : 'not ok', " 58\n";
319$r = 0;
320{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
321print $r == 120 ? 'ok' : 'not ok', " 59\n";
322
323# check that goto &sub within evals doesn't leak lexical scope
324
325my $yyy = 2;
326
327my $test = 60;
328sub 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
336eval 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};
348fred5();
349{ my $yyy = 88; my $zzz = 99; fred5(); }
e8cf733a 350eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
a3985cdc 351
e8cf733a
HS
352# [perl #9728] used to dump core
353{
354 $eval = eval 'sub { eval "sub { %S }" }';
355 $eval->({});
7e736055
HS
356 print "ok $test\n";
357 $test++;
e8cf733a 358}
a3985cdc 359
d819b83a
DM
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;
365our $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
HS
386require './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
390my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
391 stderr => 1);
392
393if ($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
RGS
424
425sub Foo {} print Foo(eval {});
426print "ok ",$test++," - #20798 (used to dump core)\n";
f48583aa
MHM
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
DM
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)',
449stderr => 1);
450
451print "not " unless $got eq "ok\n";
452print "ok $test - eval and last\n"; $test++;
453
eb034824
DM
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
RD
460 print "ok $test # eval undef \n"; $test++;
461}
462
463{
464 no warnings;
94b03d7d 465 eval "/ /b;";
500960a6
RD
466 print "not " unless $@ =~ /^syntax error/;
467 print "ok $test # eval syntax error, no warnings \n"; $test++;
eb034824
DM
468}
469
410be5db
DM
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
B
490# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
491# length $@
492$@ = "";
493eval { die "\x{a10d}"; };
494$_ = length $@;
495eval { 1 };
496
497print "not " if ($@ ne "");
498print "ok $test # length of \$@ after eval\n"; $test++;
499
500print "not " if (length $@ != 0);
501print "ok $test # length of \$@ after eval\n"; $test++;
502
93f09d7b 503# Check if eval { 1 }; completely resets $@
8433848b 504if (eval "use Devel::Peek; 1;") {
1c25d394
NC
505 $tempfile = tempfile();
506 $outfile = tempfile();
507 open PROG, ">", $tempfile or die "Can't create test file";
508 my $prog = <<'END_EVAL_TEST';
8433848b
B
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
B
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
B
525 local $/;
526 my $in = <IN>;
527 my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2);
528 $first =~ s/,pNOK//;
96d9b9cd
Z
529 s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
530 s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
8433848b
B
531 $ok = 1 if ($first eq $second);
532 }
533 }
534
535 print $ok;
8433848b 536END_EVAL_TEST
1c25d394
NC
537 $prog =~ s/\@\@\@\@/$outfile/g;
538 print PROG $prog;
8433848b
B
539 close PROG;
540
1c25d394 541 my $ok = runperl(progfile => $tempfile);
8433848b 542 print "not " unless $ok;
93f09d7b 543 print "ok $test # eval { 1 } completely resets \$@\n";
8433848b
B
544}
545else {
93f09d7b 546 print "ok $test # skipped - eval { 1 } completely resets \$@\n";
8433848b 547}
fa13de94 548$test++;
410be5db 549
fa13de94
RGS
550# Test that "use feature" and other hint transmission in evals and s///ee
551# don't leak memory
552{
553 use feature qw(:5.10);
e8514a9e 554 my $count_expected = ($^H & 0x20000) ? 2 : 1;
fa13de94
RGS
555 my $t;
556 my $s = "a";
557 $s =~ s/a/$t = \%^H; qq( qq() );/ee;
e8514a9e 558 print "not " if Internals::SvREFCNT(%$t) != $count_expected;
fa13de94
RGS
559 print "ok $test - RT 63110\n";
560 $test++;
561}
f5fa9033
NC
562
563curr_test($test);
564
3b9d46a3
GG
565{
566 # test that the CV compiled for the eval is freed by checking that no additional
567 # reference to outside lexicals are made.
568 my $x;
569 is(Internals::SvREFCNT($x), 1, "originally only 1 referece");
570 eval '$x';
571 is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
572}
573
f5fa9033
NC
574fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
575$::{'@'}='';
576eval {};
577print "ok\n";
578EOP
579
580fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
581eval {
582 $::{'@'}='';
583};
584print "ok\n";
585EOP
dfd167e9
NC
586
587fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
588$::{'@'}=\3;
589eval {};
590print "ok\n";
591EOP
592
593fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
594eval {
595 $::{'@'}=\3;
596};
597print "ok\n";
598EOP
ae533554 599
ae533554
FR
600 fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals');
601# localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ
602BEGIN { $^H |= 0x00020000 }
603eval q{ eval { + } };
604print "ok\n";
605EOP
f678642f 606
3e5c0189
DM
607fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
608use overload '""' => sub { '1;' };
609my $ov = bless [];
610eval $ov;
611print "ok\n";
612EOP
613
3aadd5cd
FC
614for my $k (!0) {
615 eval 'my $do_something_with = $k';
616 eval { $k = 'mon' };
617 is "a" =~ /a/, "1",
618 "string eval leaves readonly lexicals readonly [perl #19135]";
619}