This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don’t LEAVE_with_name("evalcomp") for syntax errors
[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
bbde7ba3 9plan(tests => 121);
a559c259 10
b38b3145 11eval 'pass();';
a559c259 12
b38b3145 13is($@, '');
a559c259
LW
14
15eval "\$foo\n = # this is a comment\n'ok 3';";
b38b3145 16is($foo, 'ok 3');
a559c259
LW
17
18eval "\$foo\n = # this is a comment\n'ok 4\n';";
b38b3145 19is($foo, "ok 4\n");
a559c259 20
378cc40b 21print eval '
79072805 22$foo =;'; # this tests for a call through yyerror()
b38b3145 23like($@, qr/line 2/);
a559c259 24
378cc40b 25print eval '$foo = /'; # this tests for a call through fatal()
b38b3145 26like($@, qr/Search/);
378cc40b 27
b38b3145 28is(eval '"ok 7\n";', "ok 7\n");
378cc40b
LW
29
30$foo = 5;
31$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
32$ans = eval $fact;
b38b3145 33is($ans, 120, 'calculate a factorial with recursive evals');
378cc40b
LW
34
35$foo = 5;
a687059c 36$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
378cc40b 37$ans = eval $fact;
b38b3145 38is($ans, 120, 'calculate a factorial with recursive evals');
378cc40b 39
b38b3145 40my $curr_test = curr_test();
1c25d394
NC
41my $tempfile = tempfile();
42open(try,'>',$tempfile);
b38b3145 43print try 'print "ok $curr_test\n";',"\n";
378cc40b
LW
44close try;
45
1c25d394 46do "./$tempfile"; print $@;
99b89507
LW
47
48# Test the singlequoted eval optimizer
49
b38b3145 50$i = $curr_test + 1;
99b89507
LW
51for (1..3) {
52 eval 'print "ok ", $i++, "\n"';
53}
54
b38b3145
NC
55$curr_test += 4;
56
99b89507 57eval {
b38b3145
NC
58 print "ok $curr_test\n";
59 die sprintf "ok %d\n", $curr_test + 2;
99b89507 60 1;
b38b3145
NC
61} || printf "ok %d\n$@", $curr_test + 1;
62
63curr_test($curr_test + 3);
99b89507 64
c7cc6f1c
GS
65# check whether eval EXPR determines value of EXPR correctly
66
67{
68 my @a = qw(a b c d);
69 my @b = eval @a;
b38b3145
NC
70 is("@b", '4');
71 is($@, '');
c7cc6f1c
GS
72
73 my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
74 my $b;
75 @a = eval $a;
b38b3145
NC
76 is("@a", 'A');
77 is( $b, 'A');
c7cc6f1c 78 $_ = eval $a;
b38b3145 79 is( $b, 'S');
c7cc6f1c 80 eval $a;
b38b3145 81 is( $b, 'V');
fc360e46
AB
82
83 $b = 'wrong';
84 $x = sub {
85 my $b = "right";
b38b3145 86 is(eval('"$b"'), $b);
fc360e46
AB
87 };
88 &$x();
c7cc6f1c 89}
155fc61f 90
b38b3145
NC
91{
92 my $b = 'wrong';
93 my $X = sub {
94 my $b = "right";
95 is(eval('"$b"'), $b);
96 };
97 &$X();
98}
155fc61f
GS
99
100# check navigation of multiple eval boundaries to find lexicals
101
b38b3145 102my $x = 'aa';
155fc61f 103eval <<'EOT'; die if $@;
0a00efa0
GS
104 print "# $x\n"; # clone into eval's pad
105 sub do_eval1 {
155fc61f
GS
106 eval $_[0]; die if $@;
107 }
108EOT
b38b3145 109do_eval1('is($x, "aa")');
155fc61f 110$x++;
b38b3145 111do_eval1('eval q[is($x, "ab")]');
155fc61f 112$x++;
b38b3145 113do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
0a00efa0
GS
114$x++;
115
116# calls from within eval'' should clone outer lexicals
117
118eval <<'EOT'; die if $@;
119 sub do_eval2 {
120 eval $_[0]; die if $@;
121 }
b38b3145 122do_eval2('is($x, "ad")');
0a00efa0 123$x++;
b38b3145 124do_eval2('eval q[is($x, "ae")]');
0a00efa0 125$x++;
b38b3145 126do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
0a00efa0
GS
127EOT
128
129# calls outside eval'' should NOT clone lexicals from called context
130
a3985cdc
DM
131$main::ok = 'not ok';
132my $ok = 'ok';
0a00efa0
GS
133eval <<'EOT'; die if $@;
134 # $x unbound here
135 sub do_eval3 {
136 eval $_[0]; die if $@;
137 }
138EOT
a3985cdc
DM
139{
140 my $ok = 'not ok';
b38b3145
NC
141 do_eval3('is($ok, q{ok})');
142 do_eval3('eval q[is($ok, q{ok})]');
143 do_eval3('sub { eval q[is($ok, q{ok})] }->()');
a3985cdc 144}
6b35e009 145
6b35e009 146{
b38b3145
NC
147 my $x = curr_test();
148 my $got;
149 sub recurse {
150 my $l = shift;
151 if ($l < $x) {
152 ++$l;
153 eval 'print "# level $l\n"; recurse($l);';
154 die if $@;
155 }
156 else {
157 $got = "ok $l";
158 }
159 }
160 local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ };
161 recurse(curr_test() - 5);
162
163 is($got, "ok $x",
164 "recursive subroutine-call inside eval'' see its own lexicals");
6b35e009 165}
33b8ce05 166
b38b3145 167
33b8ce05
GS
168eval <<'EOT';
169 sub create_closure {
170 my $self = shift;
171 return sub {
b38b3145 172 return $self;
33b8ce05
GS
173 };
174 }
175EOT
b38b3145
NC
176is(create_closure("good")->(), "good",
177 'closures created within eval bind correctly');
2680586e 178
b38b3145
NC
179$main::r = "good";
180sub terminal { eval '$r . q{!}' }
181is(do {
182 my $r = "bad";
2680586e 183 eval 'terminal($r)';
b38b3145 184}, 'good!', 'lexical search terminates correctly at subroutine boundary');
2680586e 185
b38b3145
NC
186{
187 # Have we cured panic which occurred with require/eval in die handler ?
188 local $SIG{__DIE__} = sub { eval {1}; die shift };
189 eval { die "wham_eth\n" };
190 is($@, "wham_eth\n");
191}
a7c6d244 192
a7ec2b44
GS
193{
194 my $c = eval "(1,2)x10";
b38b3145 195 is($c, '2222222222', 'scalar eval"" pops stack correctly');
a7ec2b44 196}
b45de488
GS
197
198# return from eval {} should clear $@ correctly
199{
200 my $status = eval {
201 eval { die };
202 print "# eval { return } test\n";
203 return; # removing this changes behavior
204 };
b38b3145 205 is($@, '', 'return from eval {} should clear $@ correctly');
b45de488
GS
206}
207
208# ditto for eval ""
209{
210 my $status = eval q{
211 eval q{ die };
212 print "# eval q{ return } test\n";
213 return; # removing this changes behavior
214 };
b38b3145 215 is($@, '', 'return from eval "" should clear $@ correctly');
b45de488 216}
3b2447bc
RH
217
218# Check that eval catches bad goto calls
219# (BUG ID 20010305.003)
220{
221 eval {
222 eval { goto foo; };
b38b3145
NC
223 like($@, qr/Can't "goto" into the middle of a foreach loop/,
224 'eval catches bad goto calls');
3b2447bc
RH
225 last;
226 foreach my $i (1) {
b38b3145 227 foo: fail('jumped into foreach');
3b2447bc
RH
228 }
229 };
b38b3145
NC
230 fail("Outer eval didn't execute the last");
231 diag($@);
3b2447bc 232}
b6512f48
MJD
233
234# Make sure that "my $$x" is forbidden
235# 20011224 MJD
236{
b38b3145
NC
237 foreach (qw($$x @$x %$x $$$x)) {
238 eval 'my ' . $_;
239 isnt($@, '', "my $_ is forbidden");
240 }
b6512f48 241}
16a5162e 242
16a5162e
JH
243{
244 $@ = 5;
245 eval q{};
b38b3145 246 cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
16a5162e 247}
a3985cdc
DM
248
249# DAPM Nov-2002. Perl should now capture the full lexical context during
250# evals.
251
252$::zzz = $::zzz = 0;
253my $zzz = 1;
254
255eval q{
256 sub fred1 {
b38b3145 257 eval q{ is(eval '$zzz', 1); }
a3985cdc
DM
258 }
259 fred1(47);
260 { my $zzz = 2; fred1(48) }
261};
262
263eval q{
264 sub fred2 {
b38b3145 265 is(eval('$zzz'), 1);
a3985cdc
DM
266 }
267};
268fred2(49);
269{ my $zzz = 2; fred2(50) }
270
271# sort() starts a new context stack. Make sure we can still find
272# the lexically enclosing sub
273
274sub do_sort {
275 my $zzz = 2;
276 my @a = sort
b38b3145 277 { is(eval('$zzz'), 2); $a <=> $b }
a3985cdc
DM
278 2, 1;
279}
280do_sort();
281
282# more recursion and lexical scope leak tests
283
284eval q{
285 my $r = -1;
286 my $yyy = 9;
287 sub fred3 {
288 my $l = shift;
289 my $r = -2;
290 return 1 if $l < 1;
291 return 0 if eval '$zzz' != 1;
292 return 0 if $yyy != 9;
293 return 0 if eval '$yyy' != 9;
294 return 0 if eval '$l' != $l;
295 return $l * fred3($l-1);
296 }
297 my $r = fred3(5);
b38b3145 298 is($r, 120);
a3985cdc 299 $r = eval'fred3(5)';
b38b3145 300 is($r, 120);
a3985cdc
DM
301 $r = 0;
302 eval '$r = fred3(5)';
b38b3145 303 is($r, 120);
a3985cdc
DM
304 $r = 0;
305 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
b38b3145 306 is($r, 120);
a3985cdc
DM
307};
308my $r = fred3(5);
b38b3145 309is($r, 120);
a3985cdc 310$r = eval'fred3(5)';
b38b3145 311is($r, 120);
a3985cdc
DM
312$r = 0;
313eval'$r = fred3(5)';
b38b3145 314is($r, 120);
a3985cdc
DM
315$r = 0;
316{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
b38b3145 317is($r, 120);
a3985cdc
DM
318
319# check that goto &sub within evals doesn't leak lexical scope
320
321my $yyy = 2;
322
a3985cdc
DM
323sub fred4 {
324 my $zzz = 3;
b38b3145
NC
325 is($zzz, 3);
326 is(eval '$zzz', 3);
327 is(eval '$yyy', 2);
a3985cdc
DM
328}
329
330eval q{
331 fred4();
332 sub fred5 {
333 my $zzz = 4;
b38b3145
NC
334 is($zzz, 4);
335 is(eval '$zzz', 4);
336 is(eval '$yyy', 2);
a3985cdc
DM
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{
346 $eval = eval 'sub { eval "sub { %S }" }';
347 $eval->({});
b38b3145 348 pass('[perl #9728] used to dump core');
e8cf733a 349}
a3985cdc 350
d819b83a
DM
351# evals that appear in the DB package should see the lexical scope of the
352# thing outside DB that called them (usually the debugged code), rather
353# than the usual surrounding scope
354
d819b83a
DM
355our $x = 1;
356{
357 my $x=2;
358 sub db1 { $x; eval '$x' }
359 sub DB::db2 { $x; eval '$x' }
360 package DB;
361 sub db3 { eval '$x' }
362 sub DB::db4 { eval '$x' }
363 sub db5 { my $x=4; eval '$x' }
364 package main;
365 sub db6 { my $x=4; eval '$x' }
366}
367{
368 my $x = 3;
b38b3145
NC
369 is(db1(), 2);
370 is(DB::db2(), 2);
371 is(DB::db3(), 3);
372 is(DB::db4(), 3);
373 is(DB::db5(), 3);
374 is(db6(), 4);
d819b83a 375}
b38b3145 376
7e736055
HS
377# [perl #19022] used to end up with shared hash warnings
378# The program should generate no output, so anything we see is on stderr
379my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
380 stderr => 1);
b38b3145 381is ($got, '');
7e736055
HS
382
383# And a buggy way of fixing #19022 made this fail - $k became undef after the
384# eval for a build with copy on write
385{
386 my %h;
387 $h{a}=1;
388 foreach my $k (keys %h) {
b38b3145 389 is($k, 'a');
7e736055
HS
390
391 eval "\$k";
392
b38b3145 393 is($k, 'a');
7e736055
HS
394 }
395}
77d32bb7
RGS
396
397sub Foo {} print Foo(eval {});
b38b3145 398pass('#20798 (used to dump core)');
f48583aa
MHM
399
400# check for context in string eval
401{
402 my(@r,$r,$c);
403 sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
404
405 my $code = q{ context() };
406 @r = qw( a b );
407 $r = 'ab';
408 @r = eval $code;
b38b3145 409 is("@r$c", 'AA', 'string eval list context');
f48583aa 410 $r = eval $code;
b38b3145 411 is("$r$c", 'SS', 'string eval scalar context');
f48583aa 412 eval $code;
b38b3145 413 is("$c", 'V', 'string eval void context');
f48583aa 414}
6ab4a6ff
DM
415
416# [perl #34682] escaping an eval with last could coredump or dup output
417
418$got = runperl (
419 prog =>
420 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
421stderr => 1);
422
b38b3145 423is($got, "ok\n", 'eval and last');
6ab4a6ff 424
eb034824
DM
425# eval undef should be the same as eval "" barring any warnings
426
427{
428 local $@ = "foo";
429 eval undef;
b38b3145 430 is($@, "", 'eval undef');
500960a6
RD
431}
432
433{
434 no warnings;
94b03d7d 435 eval "/ /b;";
b38b3145 436 like($@, qr/^syntax error/, 'eval syntax error, no warnings');
eb034824
DM
437}
438
59a97017 439# a syntax error in an eval called magically (eg via tie or overload)
410be5db 440# resulted in an assertion failure in S_docatch, since doeval had already
59a97017 441# popped the EVAL context due to the failure, but S_docatch expected the
410be5db
DM
442# context to still be there.
443
444{
445 my $ok = 0;
446 package Eval1;
447 sub STORE { eval '('; $ok = 1 }
448 sub TIESCALAR { bless [] }
449
450 my $x;
451 tie $x, bless [];
452 $x = 1;
b38b3145 453 ::is($ok, 1, 'eval docatch');
410be5db
DM
454}
455
8433848b
B
456# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
457# length $@
458$@ = "";
459eval { die "\x{a10d}"; };
460$_ = length $@;
461eval { 1 };
462
b38b3145
NC
463cmp_ok($@, 'eq', "", 'length of $@ after eval');
464cmp_ok(length $@, '==', 0, 'length of $@ after eval');
0d804ff6 465
93f09d7b 466# Check if eval { 1 }; completely resets $@
0d804ff6 467SKIP: {
e0d4127d
NC
468 skip_if_miniperl('no dynamic loading on miniperl, no Devel::Peek', 2);
469 require Config;
470 skip('Devel::Peek was not built', 2)
471 unless $Config::Config{extensions} =~ /\bDevel\/Peek\b/;
0d804ff6
NC
472
473 my $tempfile = tempfile();
474 open $prog, ">", $tempfile or die "Can't create test file";
475 print $prog <<'END_EVAL_TEST';
8433848b
B
476 use Devel::Peek;
477 $! = 0;
478 $@ = $!;
0d804ff6
NC
479 Dump($@);
480 print STDERR "******\n";
481 eval { die "\x{a10d}"; };
482 $_ = length $@;
483 eval { 1 };
484 Dump($@);
485 print STDERR "******\n";
486 print STDERR "Done\n";
8433848b 487END_EVAL_TEST
0d804ff6
NC
488 close $prog or die "Can't close $tempfile: $!";
489 my $got = runperl(progfile => $tempfile, stderr => 1);
490 my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got);
8433848b 491
0d804ff6
NC
492 is($tombstone, "Done\n", 'Program completed successfully');
493
494 $first =~ s/,pNOK//;
495 s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
496 s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
673f72bf
CB
497 # Dump may double newlines through pipes, though not files
498 # which is what this test used to use.
499 $second =~ s/ IV = 0\n\n/ IV = 0\n/ if $^O eq 'VMS';
0d804ff6
NC
500
501 is($second, $first, 'eval { 1 } completely resets $@');
8433848b 502}
410be5db 503
fa13de94
RGS
504# Test that "use feature" and other hint transmission in evals and s///ee
505# don't leak memory
506{
507 use feature qw(:5.10);
e8514a9e 508 my $count_expected = ($^H & 0x20000) ? 2 : 1;
fa13de94
RGS
509 my $t;
510 my $s = "a";
511 $s =~ s/a/$t = \%^H; qq( qq() );/ee;
0d804ff6 512 is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
fa13de94 513}
f5fa9033 514
3b9d46a3
GG
515{
516 # test that the CV compiled for the eval is freed by checking that no additional
517 # reference to outside lexicals are made.
518 my $x;
1c2e8cca 519 is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
3b9d46a3
GG
520 eval '$x';
521 is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
522}
523
f5fa9033
NC
524fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
525$::{'@'}='';
526eval {};
527print "ok\n";
528EOP
529
530fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
531eval {
532 $::{'@'}='';
533};
534print "ok\n";
535EOP
dfd167e9
NC
536
537fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
538$::{'@'}=\3;
539eval {};
540print "ok\n";
541EOP
542
543fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
544eval {
545 $::{'@'}=\3;
546};
547print "ok\n";
548EOP
ae533554 549
ae533554
FR
550 fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals');
551# localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ
552BEGIN { $^H |= 0x00020000 }
553eval q{ eval { + } };
554print "ok\n";
555EOP
f678642f 556
3e5c0189
DM
557fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
558use overload '""' => sub { '1;' };
559my $ov = bless [];
560eval $ov;
561print "ok\n";
562EOP
563
3aadd5cd
FC
564for my $k (!0) {
565 eval 'my $do_something_with = $k';
566 eval { $k = 'mon' };
567 is "a" =~ /a/, "1",
568 "string eval leaves readonly lexicals readonly [perl #19135]";
569}
bc344123 570
a72a1094 571# [perl #68750]
bc344123
FC
572fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H');
573 BEGIN {
574 require re; re->import('/x'); # should only affect surrounding scope
575 eval '
576 print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
577 use re "/m";
578 print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
579 ';
580 }
581 print "ab" =~ /a b/ ? "ok\n" : "nokay\n";
582EOP
f45b078d
FC
583
584# [perl #70151]
585{
586 BEGIN { eval 'require re; import re "/x"' }
587 ok "ab" =~ /a b/, 'eval does not localise %^H at run time';
588}
bbde7ba3
FC
589
590# The fix for perl #70151 caused an assertion failure that broke
591# SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails.
592eval(q|""!=!~//|);
593pass("phew! dodged the assertion after a parsing (not lexing) error");