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