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
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     @INC = () unless is_miniperl();
7     unshift @INC, '../lib';
8 }
9
10 plan(tests => 132);
11
12 eval 'pass();';
13
14 is($@, '');
15
16 eval "\$foo\n    = # this is a comment\n'ok 3';";
17 is($foo, 'ok 3');
18
19 eval "\$foo\n    = # this is a comment\n'ok 4\n';";
20 is($foo, "ok 4\n");
21
22 print eval '
23 $foo =;';               # this tests for a call through yyerror()
24 like($@, qr/line 2/);
25
26 print eval '$foo = /';  # this tests for a call through fatal()
27 like($@, qr/Search/);
28
29 is scalar(eval '++'), undef, 'eval syntax error in scalar context';
30 is scalar(eval 'die'), undef, 'eval run-time error in scalar context';
31 is +()=eval '++', 0, 'eval syntax error in list context';
32 is +()=eval 'die', 0, 'eval run-time error in list context';
33
34 is(eval '"ok 7\n";', "ok 7\n");
35
36 $foo = 5;
37 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
38 $ans = eval $fact;
39 is($ans, 120, 'calculate a factorial with recursive evals');
40
41 $foo = 5;
42 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
43 $ans = eval $fact;
44 is($ans, 120, 'calculate a factorial with recursive evals');
45
46 my $curr_test = curr_test();
47 my $tempfile = tempfile();
48 open(try,'>',$tempfile);
49 print try 'print "ok $curr_test\n";',"\n";
50 close try;
51
52 do "./$tempfile"; print $@;
53
54 # Test the singlequoted eval optimizer
55
56 $i = $curr_test + 1;
57 for (1..3) {
58     eval 'print "ok ", $i++, "\n"';
59 }
60
61 $curr_test += 4;
62
63 eval {
64     print "ok $curr_test\n";
65     die sprintf "ok %d\n", $curr_test + 2;
66     1;
67 } || printf "ok %d\n$@", $curr_test + 1;
68
69 curr_test($curr_test + 3);
70
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;
76   is("@b", '4');
77   is($@, '');
78
79   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
80   my $b;
81   @a = eval $a;
82   is("@a", 'A');
83   is(  $b, 'A');
84   $_ = eval $a;
85   is(  $b, 'S');
86   eval $a;
87   is(  $b, 'V');
88
89   $b = 'wrong';
90   $x = sub {
91      my $b = "right";
92      is(eval('"$b"'), $b);
93   };
94   &$x();
95 }
96
97 {
98   my $b = 'wrong';
99   my $X = sub {
100      my $b = "right";
101      is(eval('"$b"'), $b);
102   };
103   &$X();
104 }
105
106 # check navigation of multiple eval boundaries to find lexicals
107
108 my $x = 'aa';
109 eval <<'EOT'; die if $@;
110   print "# $x\n";       # clone into eval's pad
111   sub do_eval1 {
112      eval $_[0]; die if $@;
113   }
114 EOT
115 do_eval1('is($x, "aa")');
116 $x++;
117 do_eval1('eval q[is($x, "ab")]');
118 $x++;
119 do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
120 $x++;
121
122 # calls from within eval'' should clone outer lexicals
123
124 eval <<'EOT'; die if $@;
125   sub do_eval2 {
126      eval $_[0]; die if $@;
127   }
128 do_eval2('is($x, "ad")');
129 $x++;
130 do_eval2('eval q[is($x, "ae")]');
131 $x++;
132 do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
133 EOT
134
135 # calls outside eval'' should NOT clone lexicals from called context
136
137 $main::ok = 'not ok';
138 my $ok = 'ok';
139 eval <<'EOT'; die if $@;
140   # $x unbound here
141   sub do_eval3 {
142      eval $_[0]; die if $@;
143   }
144 EOT
145 {
146     my $ok = 'not ok';
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})] }->()');
150 }
151
152 {
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");
171 }
172
173
174 eval <<'EOT';
175   sub create_closure {
176     my $self = shift;
177     return sub {
178        return $self;
179     };
180   }
181 EOT
182 is(create_closure("good")->(), "good",
183    'closures created within eval bind correctly');
184
185 $main::r = "good";
186 sub terminal { eval '$r . q{!}' }
187 is(do {
188    my $r = "bad";
189    eval 'terminal($r)';
190 }, 'good!', 'lexical search terminates correctly at subroutine boundary');
191
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 }
198
199 {
200     my $c = eval "(1,2)x10";
201     is($c, '2222222222', 'scalar eval"" pops stack correctly');
202 }
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     };
211     is($@, '', 'return from eval {} should clear $@ correctly');
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     };
221     is($@, '', 'return from eval "" should clear $@ correctly');
222 }
223
224 # Check that eval catches bad goto calls
225 #   (BUG ID 20010305.003)
226 {
227     eval {
228         eval { goto foo; };
229         like($@, qr/Can't "goto" into the middle of a foreach loop/,
230              'eval catches bad goto calls');
231         last;
232         foreach my $i (1) {
233             foo: fail('jumped into foreach');
234         }
235     };
236     fail("Outer eval didn't execute the last");
237     diag($@);
238 }
239
240 # Make sure that "my $$x" is forbidden
241 # 20011224 MJD
242 {
243     foreach (qw($$x @$x %$x $$$x)) {
244         eval 'my ' . $_;
245         isnt($@, '', "my $_ is forbidden");
246     }
247 }
248
249 {
250     $@ = 5;
251     eval q{};
252     cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
253 }
254
255 # DAPM Nov-2002. Perl should now capture the full lexical context during
256 # evals.
257
258 $::zzz = $::zzz = 0;
259 my $zzz = 1;
260
261 eval q{
262     sub fred1 {
263         eval q{ is(eval '$zzz', 1); }
264     }
265     fred1(47);
266     { my $zzz = 2; fred1(48) }
267 };
268
269 eval q{
270     sub fred2 {
271         is(eval('$zzz'), 1);
272     }
273 };
274 fred2(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
280 sub do_sort {
281     my $zzz = 2;
282     my @a = sort
283             { is(eval('$zzz'), 2); $a <=> $b }
284             2, 1;
285 }
286 do_sort();
287
288 # more recursion and lexical scope leak tests
289
290 eval 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);
304     is($r, 120);
305     $r = eval'fred3(5)';
306     is($r, 120);
307     $r = 0;
308     eval '$r = fred3(5)';
309     is($r, 120);
310     $r = 0;
311     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
312     is($r, 120);
313 };
314 my $r = fred3(5);
315 is($r, 120);
316 $r = eval'fred3(5)';
317 is($r, 120);
318 $r = 0;
319 eval'$r = fred3(5)';
320 is($r, 120);
321 $r = 0;
322 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
323 is($r, 120);
324
325 # check that goto &sub within evals doesn't leak lexical scope
326
327 my $yyy = 2;
328
329 sub fred4 { 
330     my $zzz = 3;
331     is($zzz, 3);
332     is(eval '$zzz', 3);
333     is(eval '$yyy', 2);
334 }
335
336 eval q{
337     fred4();
338     sub fred5 {
339         my $zzz = 4;
340         is($zzz, 4);
341         is(eval '$zzz', 4);
342         is(eval '$yyy', 2);
343         goto &fred4;
344     }
345     fred5();
346 };
347 fred5();
348 { my $yyy = 88; my $zzz = 99; fred5(); }
349 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
350
351 {
352    $eval = eval 'sub { eval "sub { %S }" }';
353    $eval->({});
354    pass('[perl #9728] used to dump core');
355 }
356
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
361 our $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;
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);
381 }
382
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
385 my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
386                    stderr => 1);
387 is ($got, '');
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) {
395     is($k, 'a');
396
397     eval "\$k";
398
399     is($k, 'a');
400   }
401 }
402
403 sub Foo {} print Foo(eval {});
404 pass('#20798 (used to dump core)');
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;
415   is("@r$c", 'AA', 'string eval list context');
416   $r = eval $code;
417   is("$r$c", 'SS', 'string eval scalar context');
418   eval $code;
419   is("$c", 'V', 'string eval void context');
420 }
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)',
427 stderr => 1);
428
429 is($got, "ok\n", 'eval and last');
430
431 # eval undef should be the same as eval "" barring any warnings
432
433 {
434     local $@ = "foo";
435     eval undef;
436     is($@, "", 'eval undef');
437 }
438
439 {
440     no warnings;
441     eval "&& $b;";
442     like($@, qr/^syntax error/, 'eval syntax error, no warnings');
443 }
444
445 # a syntax error in an eval called magically (eg via tie or overload)
446 # resulted in an assertion failure in S_docatch, since doeval had already
447 # popped the EVAL context due to the failure, but S_docatch expected the
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;
459     ::is($ok, 1, 'eval docatch');
460 }
461
462 # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
463 # length $@ 
464 $@ = "";
465 eval { die "\x{a10d}"; };
466 $_ = length $@;
467 eval { 1 };
468
469 cmp_ok($@, 'eq', "", 'length of $@ after eval');
470 cmp_ok(length $@, '==', 0, 'length of $@ after eval');
471
472 # Check if eval { 1 }; completely resets $@
473 SKIP: {
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/;
478
479     my $tempfile = tempfile();
480     open $prog, ">", $tempfile or die "Can't create test file";
481     print $prog <<'END_EVAL_TEST';
482     use Devel::Peek;
483     $! = 0;
484     $@ = $!;
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";
493 END_EVAL_TEST
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);
497
498     is($tombstone, "Done\n", 'Program completed successfully');
499
500     $first =~ s/p?[NI]OK,//g;
501     s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
502     s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
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';
506
507     is($second, $first, 'eval { 1 } completely resets $@');
508 }
509
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);
514     my $count_expected = ($^H & 0x20000) ? 2 : 1;
515     my $t;
516     my $s = "a";
517     $s =~ s/a/$t = \%^H;  qq( qq() );/ee;
518     is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
519 }
520
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
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;
535     is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
536     eval '$x';
537     is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
538 }
539
540 fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
541 $::{'@'}='';
542 eval {};
543 print "ok\n";
544 EOP
545
546 fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
547 eval {
548     $::{'@'}='';
549 };
550 print "ok\n";
551 EOP
552
553 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
554 $::{'@'}=\3;
555 eval {};
556 print "ok\n";
557 EOP
558
559 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
560 eval {
561     $::{'@'}=\3;
562 };
563 print "ok\n";
564 EOP
565
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
568 BEGIN { $^H |= 0x00020000 }
569 eval q{ eval { + } };
570 print "ok\n";
571 EOP
572
573 fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
574 use overload '""'  => sub { '1;' };
575 my $ov = bless [];
576 eval $ov;
577 print "ok\n";
578 EOP
579
580 for 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 }
586
587 # [perl #68750]
588 fresh_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";
598 EOP
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 }
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.
608 eval(q|""!=!~//|);
609 pass("phew! dodged the assertion after a parsing (not lexing) error");
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 }
623
624 # [perl #114658] Line numbers at end of string eval
625 for("{;", "{") {
626     eval $_; is $@ =~ s/eval \d+/eval 1/rag, <<'EOE',
627 Missing right curly or square bracket at (eval 1) line 1, at end of line
628 syntax error at (eval 1) line 1, at EOF
629 EOE
630         qq'Right line number for eval "$_"';
631 }
632
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
645 sub _117941 { package _117941; eval '$a' }
646 delete $::{"_117941::"};
647 _117941();
648 pass("eval in freed package does not crash");