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
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 plan(tests => 121);
10
11 eval 'pass();';
12
13 is($@, '');
14
15 eval "\$foo\n    = # this is a comment\n'ok 3';";
16 is($foo, 'ok 3');
17
18 eval "\$foo\n    = # this is a comment\n'ok 4\n';";
19 is($foo, "ok 4\n");
20
21 print eval '
22 $foo =;';               # this tests for a call through yyerror()
23 like($@, qr/line 2/);
24
25 print eval '$foo = /';  # this tests for a call through fatal()
26 like($@, qr/Search/);
27
28 is(eval '"ok 7\n";', "ok 7\n");
29
30 $foo = 5;
31 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
32 $ans = eval $fact;
33 is($ans, 120, 'calculate a factorial with recursive evals');
34
35 $foo = 5;
36 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
37 $ans = eval $fact;
38 is($ans, 120, 'calculate a factorial with recursive evals');
39
40 my $curr_test = curr_test();
41 my $tempfile = tempfile();
42 open(try,'>',$tempfile);
43 print try 'print "ok $curr_test\n";',"\n";
44 close try;
45
46 do "./$tempfile"; print $@;
47
48 # Test the singlequoted eval optimizer
49
50 $i = $curr_test + 1;
51 for (1..3) {
52     eval 'print "ok ", $i++, "\n"';
53 }
54
55 $curr_test += 4;
56
57 eval {
58     print "ok $curr_test\n";
59     die sprintf "ok %d\n", $curr_test + 2;
60     1;
61 } || printf "ok %d\n$@", $curr_test + 1;
62
63 curr_test($curr_test + 3);
64
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;
70   is("@b", '4');
71   is($@, '');
72
73   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
74   my $b;
75   @a = eval $a;
76   is("@a", 'A');
77   is(  $b, 'A');
78   $_ = eval $a;
79   is(  $b, 'S');
80   eval $a;
81   is(  $b, 'V');
82
83   $b = 'wrong';
84   $x = sub {
85      my $b = "right";
86      is(eval('"$b"'), $b);
87   };
88   &$x();
89 }
90
91 {
92   my $b = 'wrong';
93   my $X = sub {
94      my $b = "right";
95      is(eval('"$b"'), $b);
96   };
97   &$X();
98 }
99
100 # check navigation of multiple eval boundaries to find lexicals
101
102 my $x = 'aa';
103 eval <<'EOT'; die if $@;
104   print "# $x\n";       # clone into eval's pad
105   sub do_eval1 {
106      eval $_[0]; die if $@;
107   }
108 EOT
109 do_eval1('is($x, "aa")');
110 $x++;
111 do_eval1('eval q[is($x, "ab")]');
112 $x++;
113 do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
114 $x++;
115
116 # calls from within eval'' should clone outer lexicals
117
118 eval <<'EOT'; die if $@;
119   sub do_eval2 {
120      eval $_[0]; die if $@;
121   }
122 do_eval2('is($x, "ad")');
123 $x++;
124 do_eval2('eval q[is($x, "ae")]');
125 $x++;
126 do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
127 EOT
128
129 # calls outside eval'' should NOT clone lexicals from called context
130
131 $main::ok = 'not ok';
132 my $ok = 'ok';
133 eval <<'EOT'; die if $@;
134   # $x unbound here
135   sub do_eval3 {
136      eval $_[0]; die if $@;
137   }
138 EOT
139 {
140     my $ok = 'not ok';
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})] }->()');
144 }
145
146 {
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");
165 }
166
167
168 eval <<'EOT';
169   sub create_closure {
170     my $self = shift;
171     return sub {
172        return $self;
173     };
174   }
175 EOT
176 is(create_closure("good")->(), "good",
177    'closures created within eval bind correctly');
178
179 $main::r = "good";
180 sub terminal { eval '$r . q{!}' }
181 is(do {
182    my $r = "bad";
183    eval 'terminal($r)';
184 }, 'good!', 'lexical search terminates correctly at subroutine boundary');
185
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 }
192
193 {
194     my $c = eval "(1,2)x10";
195     is($c, '2222222222', 'scalar eval"" pops stack correctly');
196 }
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     };
205     is($@, '', 'return from eval {} should clear $@ correctly');
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     };
215     is($@, '', 'return from eval "" should clear $@ correctly');
216 }
217
218 # Check that eval catches bad goto calls
219 #   (BUG ID 20010305.003)
220 {
221     eval {
222         eval { goto foo; };
223         like($@, qr/Can't "goto" into the middle of a foreach loop/,
224              'eval catches bad goto calls');
225         last;
226         foreach my $i (1) {
227             foo: fail('jumped into foreach');
228         }
229     };
230     fail("Outer eval didn't execute the last");
231     diag($@);
232 }
233
234 # Make sure that "my $$x" is forbidden
235 # 20011224 MJD
236 {
237     foreach (qw($$x @$x %$x $$$x)) {
238         eval 'my ' . $_;
239         isnt($@, '', "my $_ is forbidden");
240     }
241 }
242
243 {
244     $@ = 5;
245     eval q{};
246     cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
247 }
248
249 # DAPM Nov-2002. Perl should now capture the full lexical context during
250 # evals.
251
252 $::zzz = $::zzz = 0;
253 my $zzz = 1;
254
255 eval q{
256     sub fred1 {
257         eval q{ is(eval '$zzz', 1); }
258     }
259     fred1(47);
260     { my $zzz = 2; fred1(48) }
261 };
262
263 eval q{
264     sub fred2 {
265         is(eval('$zzz'), 1);
266     }
267 };
268 fred2(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
274 sub do_sort {
275     my $zzz = 2;
276     my @a = sort
277             { is(eval('$zzz'), 2); $a <=> $b }
278             2, 1;
279 }
280 do_sort();
281
282 # more recursion and lexical scope leak tests
283
284 eval 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);
298     is($r, 120);
299     $r = eval'fred3(5)';
300     is($r, 120);
301     $r = 0;
302     eval '$r = fred3(5)';
303     is($r, 120);
304     $r = 0;
305     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
306     is($r, 120);
307 };
308 my $r = fred3(5);
309 is($r, 120);
310 $r = eval'fred3(5)';
311 is($r, 120);
312 $r = 0;
313 eval'$r = fred3(5)';
314 is($r, 120);
315 $r = 0;
316 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
317 is($r, 120);
318
319 # check that goto &sub within evals doesn't leak lexical scope
320
321 my $yyy = 2;
322
323 sub fred4 { 
324     my $zzz = 3;
325     is($zzz, 3);
326     is(eval '$zzz', 3);
327     is(eval '$yyy', 2);
328 }
329
330 eval q{
331     fred4();
332     sub fred5 {
333         my $zzz = 4;
334         is($zzz, 4);
335         is(eval '$zzz', 4);
336         is(eval '$yyy', 2);
337         goto &fred4;
338     }
339     fred5();
340 };
341 fred5();
342 { my $yyy = 88; my $zzz = 99; fred5(); }
343 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
344
345 {
346    $eval = eval 'sub { eval "sub { %S }" }';
347    $eval->({});
348    pass('[perl #9728] used to dump core');
349 }
350
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
355 our $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;
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);
375 }
376
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
379 my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
380                    stderr => 1);
381 is ($got, '');
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) {
389     is($k, 'a');
390
391     eval "\$k";
392
393     is($k, 'a');
394   }
395 }
396
397 sub Foo {} print Foo(eval {});
398 pass('#20798 (used to dump core)');
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;
409   is("@r$c", 'AA', 'string eval list context');
410   $r = eval $code;
411   is("$r$c", 'SS', 'string eval scalar context');
412   eval $code;
413   is("$c", 'V', 'string eval void context');
414 }
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)',
421 stderr => 1);
422
423 is($got, "ok\n", 'eval and last');
424
425 # eval undef should be the same as eval "" barring any warnings
426
427 {
428     local $@ = "foo";
429     eval undef;
430     is($@, "", 'eval undef');
431 }
432
433 {
434     no warnings;
435     eval "/ /b;";
436     like($@, qr/^syntax error/, 'eval syntax error, no warnings');
437 }
438
439 # a syntax error in an eval called magically (eg via tie or overload)
440 # resulted in an assertion failure in S_docatch, since doeval had already
441 # popped the EVAL context due to the failure, but S_docatch expected the
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;
453     ::is($ok, 1, 'eval docatch');
454 }
455
456 # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
457 # length $@ 
458 $@ = "";
459 eval { die "\x{a10d}"; };
460 $_ = length $@;
461 eval { 1 };
462
463 cmp_ok($@, 'eq', "", 'length of $@ after eval');
464 cmp_ok(length $@, '==', 0, 'length of $@ after eval');
465
466 # Check if eval { 1 }; completely resets $@
467 SKIP: {
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/;
472
473     my $tempfile = tempfile();
474     open $prog, ">", $tempfile or die "Can't create test file";
475     print $prog <<'END_EVAL_TEST';
476     use Devel::Peek;
477     $! = 0;
478     $@ = $!;
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";
487 END_EVAL_TEST
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);
491
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;
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';
500
501     is($second, $first, 'eval { 1 } completely resets $@');
502 }
503
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);
508     my $count_expected = ($^H & 0x20000) ? 2 : 1;
509     my $t;
510     my $s = "a";
511     $s =~ s/a/$t = \%^H;  qq( qq() );/ee;
512     is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
513 }
514
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;
519     is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
520     eval '$x';
521     is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
522 }
523
524 fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
525 $::{'@'}='';
526 eval {};
527 print "ok\n";
528 EOP
529
530 fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
531 eval {
532     $::{'@'}='';
533 };
534 print "ok\n";
535 EOP
536
537 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
538 $::{'@'}=\3;
539 eval {};
540 print "ok\n";
541 EOP
542
543 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
544 eval {
545     $::{'@'}=\3;
546 };
547 print "ok\n";
548 EOP
549
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
552 BEGIN { $^H |= 0x00020000 }
553 eval q{ eval { + } };
554 print "ok\n";
555 EOP
556
557 fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
558 use overload '""'  => sub { '1;' };
559 my $ov = bless [];
560 eval $ov;
561 print "ok\n";
562 EOP
563
564 for 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 }
570
571 # [perl #68750]
572 fresh_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";
582 EOP
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 }
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.
592 eval(q|""!=!~//|);
593 pass("phew! dodged the assertion after a parsing (not lexing) error");