fix for Module/CoreList.pm 5.029009
[perl.git] / t / op / eval.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan(tests => 140);
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 scalar(eval '++'), undef, 'eval syntax error in scalar context';
29 is scalar(eval 'die'), undef, 'eval run-time error in scalar context';
30 is +()=eval '++', 0, 'eval syntax error in list context';
31 is +()=eval 'die', 0, 'eval run-time error in list context';
32
33 is(eval '"ok 7\n";', "ok 7\n");
34
35 $foo = 5;
36 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
37 $ans = eval $fact;
38 is($ans, 120, 'calculate a factorial with recursive evals');
39
40 $foo = 5;
41 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
42 $ans = eval $fact;
43 is($ans, 120, 'calculate a factorial with recursive evals');
44
45 my $curr_test = curr_test();
46 my $tempfile = tempfile();
47 open(try,'>',$tempfile);
48 print try 'print "ok $curr_test\n";',"\n";
49 close try;
50
51 do "./$tempfile"; print $@;
52
53 # Test the singlequoted eval optimizer
54
55 $i = $curr_test + 1;
56 for (1..3) {
57     eval 'print "ok ", $i++, "\n"';
58 }
59
60 $curr_test += 4;
61
62 eval {
63     print "ok $curr_test\n";
64     die sprintf "ok %d\n", $curr_test + 2;
65     1;
66 } || printf "ok %d\n$@", $curr_test + 1;
67
68 curr_test($curr_test + 3);
69
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;
75   is("@b", '4');
76   is($@, '');
77
78   my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
79   my $b;
80   @a = eval $a;
81   is("@a", 'A');
82   is(  $b, 'A');
83   $_ = eval $a;
84   is(  $b, 'S');
85   eval $a;
86   is(  $b, 'V');
87
88   $b = 'wrong';
89   $x = sub {
90      my $b = "right";
91      is(eval('"$b"'), $b);
92   };
93   &$x();
94 }
95
96 {
97   my $b = 'wrong';
98   my $X = sub {
99      my $b = "right";
100      is(eval('"$b"'), $b);
101   };
102   &$X();
103 }
104
105 # check navigation of multiple eval boundaries to find lexicals
106
107 my $x = 'aa';
108 eval <<'EOT'; die if $@;
109   print "# $x\n";       # clone into eval's pad
110   sub do_eval1 {
111      eval $_[0]; die if $@;
112   }
113 EOT
114 do_eval1('is($x, "aa")');
115 $x++;
116 do_eval1('eval q[is($x, "ab")]');
117 $x++;
118 do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
119 $x++;
120
121 # calls from within eval'' should clone outer lexicals
122
123 eval <<'EOT'; die if $@;
124   sub do_eval2 {
125      eval $_[0]; die if $@;
126   }
127 do_eval2('is($x, "ad")');
128 $x++;
129 do_eval2('eval q[is($x, "ae")]');
130 $x++;
131 do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
132 EOT
133
134 # calls outside eval'' should NOT clone lexicals from called context
135
136 $main::ok = 'not ok';
137 my $ok = 'ok';
138 eval <<'EOT'; die if $@;
139   # $x unbound here
140   sub do_eval3 {
141      eval $_[0]; die if $@;
142   }
143 EOT
144 {
145     my $ok = 'not ok';
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})] }->()');
149 }
150
151 {
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");
170 }
171
172
173 eval <<'EOT';
174   sub create_closure {
175     my $self = shift;
176     return sub {
177        return $self;
178     };
179   }
180 EOT
181 is(create_closure("good")->(), "good",
182    'closures created within eval bind correctly');
183
184 $main::r = "good";
185 sub terminal { eval '$r . q{!}' }
186 is(do {
187    my $r = "bad";
188    eval 'terminal($r)';
189 }, 'good!', 'lexical search terminates correctly at subroutine boundary');
190
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 }
197
198 {
199     my $c = eval "(1,2)x10";
200     is($c, '2222222222', 'scalar eval"" pops stack correctly');
201 }
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     };
210     is($@, '', 'return from eval {} should clear $@ correctly');
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     };
220     is($@, '', 'return from eval "" should clear $@ correctly');
221 }
222
223 # Check that eval catches bad goto calls
224 #   (BUG ID 20010305.003 (#5963))
225 {
226     eval {
227         eval { goto foo; };
228         like($@, qr/Can't "goto" into the middle of a foreach loop/,
229              'eval catches bad goto calls');
230         last;
231         foreach my $i (1) {
232             foo: fail('jumped into foreach');
233         }
234     };
235     fail("Outer eval didn't execute the last");
236     diag($@);
237 }
238
239 # Make sure that "my $$x" is forbidden
240 # 20011224 MJD
241 {
242     foreach (qw($$x @$x %$x $$$x)) {
243         eval 'my ' . $_;
244         isnt($@, '', "my $_ is forbidden");
245     }
246 }
247
248 {
249     $@ = 5;
250     eval q{};
251     cmp_ok(length $@, '==', 0, '[ID 20020623.002 (#9721)] eval "" doesn\'t clear $@');
252 }
253
254 # DAPM Nov-2002. Perl should now capture the full lexical context during
255 # evals.
256
257 $::zzz = $::zzz = 0;
258 my $zzz = 1;
259
260 eval q{
261     sub fred1 {
262         eval q{ is(eval '$zzz', 1); }
263     }
264     fred1(47);
265     { my $zzz = 2; fred1(48) }
266 };
267
268 eval q{
269     sub fred2 {
270         is(eval('$zzz'), 1);
271     }
272 };
273 fred2(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
279 sub do_sort {
280     my $zzz = 2;
281     my @a = sort
282             { is(eval('$zzz'), 2); $a <=> $b }
283             2, 1;
284 }
285 do_sort();
286
287 # more recursion and lexical scope leak tests
288
289 eval 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);
303     is($r, 120);
304     $r = eval'fred3(5)';
305     is($r, 120);
306     $r = 0;
307     eval '$r = fred3(5)';
308     is($r, 120);
309     $r = 0;
310     { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
311     is($r, 120);
312 };
313 my $r = fred3(5);
314 is($r, 120);
315 $r = eval'fred3(5)';
316 is($r, 120);
317 $r = 0;
318 eval'$r = fred3(5)';
319 is($r, 120);
320 $r = 0;
321 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
322 is($r, 120);
323
324 # check that goto &sub within evals doesn't leak lexical scope
325
326 my $yyy = 2;
327
328 sub fred4 { 
329     my $zzz = 3;
330     is($zzz, 3);
331     is(eval '$zzz', 3);
332     is(eval '$yyy', 2);
333 }
334
335 eval q{
336     fred4();
337     sub fred5 {
338         my $zzz = 4;
339         is($zzz, 4);
340         is(eval '$zzz', 4);
341         is(eval '$yyy', 2);
342         goto &fred4;
343     }
344     fred5();
345 };
346 fred5();
347 { my $yyy = 88; my $zzz = 99; fred5(); }
348 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
349
350 {
351    $eval = eval 'sub { eval "sub { %S }" }';
352    $eval->({});
353    pass('[perl #9728] used to dump core');
354 }
355
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
360 our $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;
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);
380 }
381
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
384 my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
385                    stderr => 1);
386 is ($got, '');
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) {
394     is($k, 'a');
395
396     eval "\$k";
397
398     is($k, 'a');
399   }
400 }
401
402 sub Foo {} print Foo(eval {});
403 pass('#20798 (used to dump core)');
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;
414   is("@r$c", 'AA', 'string eval list context');
415   $r = eval $code;
416   is("$r$c", 'SS', 'string eval scalar context');
417   eval $code;
418   is("$c", 'V', 'string eval void context');
419 }
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)',
426 stderr => 1);
427
428 is($got, "ok\n", 'eval and last');
429
430 # eval undef should be the same as eval "" barring any warnings
431
432 {
433     local $@ = "foo";
434     eval undef;
435     is($@, "", 'eval undef');
436 }
437
438 {
439     no warnings;
440     eval "&& $b;";
441     like($@, qr/^syntax error/, 'eval syntax error, no warnings');
442 }
443
444 # a syntax error in an eval called magically (eg via tie or overload)
445 # resulted in an assertion failure in S_docatch, since doeval_compile had
446 # already popped the EVAL context due to the failure, but S_docatch
447 # expected the 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;
458     ::is($ok, 1, 'eval docatch');
459 }
460
461 # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
462 # length $@ 
463 $@ = "";
464 eval { die "\x{a10d}"; };
465 $_ = length $@;
466 eval { 1 };
467
468 cmp_ok($@, 'eq', "", 'length of $@ after eval');
469 cmp_ok(length $@, '==', 0, 'length of $@ after eval');
470
471 # Check if eval { 1 }; completely resets $@
472 SKIP: {
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/;
477
478     my $tempfile = tempfile();
479     open $prog, ">", $tempfile or die "Can't create test file";
480     print $prog <<'END_EVAL_TEST';
481     use Devel::Peek;
482     $! = 0;
483     $@ = $!;
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";
492 END_EVAL_TEST
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);
496
497     is($tombstone, "Done\n", 'Program completed successfully');
498
499     $first =~ s/p?[NI]OK,//g;
500     s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
501     s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
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';
505
506     is($second, $first, 'eval { 1 } completely resets $@');
507 }
508
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);
513     my $count_expected = ($^H & 0x20000) ? 2 : 1;
514     my $t;
515     my $s = "a";
516     $s =~ s/a/$t = \%^H;  qq( qq() );/ee;
517     is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
518 }
519
520 # make sure default arg eval only adds a hints hash once to entereval
521 #
522 {
523     local $_ = "21+12";
524     is(eval, 33, 'argless eval without hints');
525     use feature qw(:5.10);
526     local $_ = "42+24";
527     is(eval, 66, 'argless eval with hints');
528 }
529
530 {
531     # test that the CV compiled for the eval is freed by checking that no additional 
532     # reference to outside lexicals are made.
533     my $x;
534     is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
535     eval '$x';
536     is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
537 }
538
539 fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
540 $::{'@'}='';
541 eval {};
542 print "ok\n";
543 EOP
544
545 fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
546 eval {
547     $::{'@'}='';
548 };
549 print "ok\n";
550 EOP
551
552 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
553 $::{'@'}=\3;
554 eval {};
555 print "ok\n";
556 EOP
557
558 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
559 eval {
560     $::{'@'}=\3;
561 };
562 print "ok\n";
563 EOP
564
565     fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals');
566 # localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ
567 BEGIN { $^H |= 0x00020000 }
568 eval q{ eval { + } };
569 print "ok\n";
570 EOP
571
572 fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
573 use overload '""'  => sub { '1;' };
574 my $ov = bless [];
575 eval $ov;
576 print "ok\n";
577 EOP
578
579 for my $k (!0) {
580   eval 'my $do_something_with = $k';
581   eval { $k = 'mon' };
582   is "a" =~ /a/, "1",
583     "string eval leaves readonly lexicals readonly [perl #19135]";
584 }
585
586 # [perl #68750]
587 fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H');
588   BEGIN {
589     require re; re->import('/x'); # should only affect surrounding scope
590     eval '
591       print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
592       use re "/m";
593       print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
594    ';
595   }
596   print "ab" =~ /a b/ ? "ok\n" : "nokay\n";
597 EOP
598
599 # [perl #70151]
600 {
601     BEGIN { eval 'require re; import re "/x"' }
602     ok "ab" =~ /a b/, 'eval does not localise %^H at run time';
603 }
604
605 # The fix for perl #70151 caused an assertion failure that broke
606 # SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails.
607 eval(q|""!=!~//|);
608 pass("phew! dodged the assertion after a parsing (not lexing) error");
609
610 # [perl #111462]
611 {
612    local $ENV{PERL_DESTRUCT_LEVEL} = 1;
613    unlike
614      runperl(
615       prog => 'BEGIN { $^H{foo} = bar }'
616              .'our %FIELDS; my main $x; eval q[$x->{foo}]',
617       stderr => 1,
618      ),
619      qr/Unbalanced string table/,
620     'Errors in finalize_optree do not leak string eval op tree';
621 }
622
623 # [perl #114658] Line numbers at end of string eval
624 for("{;", "{") {
625     eval $_; is $@ =~ s/eval \d+/eval 1/rag, <<'EOE',
626 Missing right curly or square bracket at (eval 1) line 1, at end of line
627 syntax error at (eval 1) line 1, at EOF
628 EOE
629         qq'Right line number for eval "$_"';
630 }
631
632 {
633     my $w;
634     local $SIG{__WARN__} = sub { $w .= shift };
635
636     eval "\${\nfoobar\n} = 10; warn q{should be line 3}";
637     is(
638         $w =~ s/eval \d+/eval 1/ra,
639         "should be line 3 at (eval 1) line 3.\n",
640         'eval qq{\${\nfoo\n}; warn} updates the line number correctly'
641     );
642 }
643
644 sub _117941 { package _117941; eval '$a' }
645 delete $::{"_117941::"};
646 _117941();
647 pass("eval in freed package does not crash");
648
649 # eval is supposed normally to clear $@ on success
650
651 {
652     $@ = 1;
653     eval q{$@ = 2};
654     ok(!$@, 'eval clearing $@');
655 }
656
657 # RT #127786
658 # this used to give an assertion failure
659
660 {
661     package DB {
662         sub f127786 { eval q/\$s/ }
663     }
664     my $s;
665     sub { $s; DB::f127786}->();
666     pass("RT #127786");
667 }
668
669 # Late calling of destructors overwriting $@.
670 # When leaving an eval scope (either by falling off the end or dying),
671 # we must ensure that any temps are freed before the end of the eval
672 # leave: in particular before $@ is set (to either "" or the error),
673 # because otherwise the tmps freeing may call a destructor which
674 # will change $@ (e.g. due to a successful eval) *after* its been set.
675 # Some extra nested scopes are included in the tests to ensure they don't
676 # affect the tmps freeing.
677
678 {
679     package TMPS;
680     sub DESTROY { eval { die "died in DESTROY"; } } # alters $@
681
682     eval { { 1; { 1; bless []; } } };
683     ::is ($@, "", "FREETMPS: normal try exit");
684
685     eval q{ { 1; { 1; bless []; } } };
686     ::is ($@, "", "FREETMPS: normal string eval exit");
687
688     eval { { 1; { 1; return bless []; } } };
689     ::is ($@, "", "FREETMPS: return try exit");
690
691     eval q{ { 1; { 1; return bless []; } } };
692     ::is ($@, "", "FREETMPS: return string eval exit");
693
694     eval { { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } };
695     ::like ($@, qr/die in eval/, "FREETMPS: die try exit");
696
697     eval q{ { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } };
698     ::like ($@, qr/die in eval/, "FREETMPS: die eval string exit");
699 }