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