6 @INC = () unless is_miniperl();
7 unshift @INC, '../lib';
16 eval "\$foo\n = # this is a comment\n'ok 3';";
19 eval "\$foo\n = # this is a comment\n'ok 4\n';";
23 $foo =;'; # this tests for a call through yyerror()
26 print eval '$foo = /'; # this tests for a call through fatal()
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';
34 is(eval '"ok 7\n";', "ok 7\n");
37 $fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
39 is($ans, 120, 'calculate a factorial with recursive evals');
42 $fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
44 is($ans, 120, 'calculate a factorial with recursive evals');
46 my $curr_test = curr_test();
47 my $tempfile = tempfile();
48 open(try,'>',$tempfile);
49 print try 'print "ok $curr_test\n";',"\n";
52 do "./$tempfile"; print $@;
54 # Test the singlequoted eval optimizer
58 eval 'print "ok ", $i++, "\n"';
64 print "ok $curr_test\n";
65 die sprintf "ok %d\n", $curr_test + 2;
67 } || printf "ok %d\n$@", $curr_test + 1;
69 curr_test($curr_test + 3);
71 # check whether eval EXPR determines value of EXPR correctly
79 my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
101 is(eval('"$b"'), $b);
106 # check navigation of multiple eval boundaries to find lexicals
109 eval <<'EOT'; die if $@;
110 print "# $x\n"; # clone into eval's pad
112 eval $_[0]; die if $@;
115 do_eval1('is($x, "aa")');
117 do_eval1('eval q[is($x, "ab")]');
119 do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
122 # calls from within eval'' should clone outer lexicals
124 eval <<'EOT'; die if $@;
126 eval $_[0]; die if $@;
128 do_eval2('is($x, "ad")');
130 do_eval2('eval q[is($x, "ae")]');
132 do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
135 # calls outside eval'' should NOT clone lexicals from called context
137 $main::ok = 'not ok';
139 eval <<'EOT'; die if $@;
142 eval $_[0]; die if $@;
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})] }->()');
159 eval 'print "# level $l\n"; recurse($l);';
166 local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ };
167 recurse(curr_test() - 5);
170 "recursive subroutine-call inside eval'' see its own lexicals");
182 is(create_closure("good")->(), "good",
183 'closures created within eval bind correctly');
186 sub terminal { eval '$r . q{!}' }
190 }, 'good!', 'lexical search terminates correctly at subroutine boundary');
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");
200 my $c = eval "(1,2)x10";
201 is($c, '2222222222', 'scalar eval"" pops stack correctly');
204 # return from eval {} should clear $@ correctly
208 print "# eval { return } test\n";
209 return; # removing this changes behavior
211 is($@, '', 'return from eval {} should clear $@ correctly');
218 print "# eval q{ return } test\n";
219 return; # removing this changes behavior
221 is($@, '', 'return from eval "" should clear $@ correctly');
224 # Check that eval catches bad goto calls
225 # (BUG ID 20010305.003)
229 like($@, qr/Can't "goto" into the middle of a foreach loop/,
230 'eval catches bad goto calls');
233 foo: fail('jumped into foreach');
236 fail("Outer eval didn't execute the last");
240 # Make sure that "my $$x" is forbidden
243 foreach (qw($$x @$x %$x $$$x)) {
245 isnt($@, '', "my $_ is forbidden");
252 cmp_ok(length $@, '==', 0, '[ID 20020623.002] eval "" doesn\'t clear $@');
255 # DAPM Nov-2002. Perl should now capture the full lexical context during
263 eval q{ is(eval '$zzz', 1); }
266 { my $zzz = 2; fred1(48) }
275 { my $zzz = 2; fred2(50) }
277 # sort() starts a new context stack. Make sure we can still find
278 # the lexically enclosing sub
283 { is(eval('$zzz'), 2); $a <=> $b }
288 # more recursion and lexical scope leak tests
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);
308 eval '$r = fred3(5)';
311 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
322 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
325 # check that goto &sub within evals doesn't leak lexical scope
348 { my $yyy = 88; my $zzz = 99; fred5(); }
349 eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
352 $eval = eval 'sub { eval "sub { %S }" }';
354 pass('[perl #9728] used to dump core');
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
364 sub db1 { $x; eval '$x' }
365 sub DB::db2 { $x; eval '$x' }
367 sub db3 { eval '$x' }
368 sub DB::db4 { eval '$x' }
369 sub db5 { my $x=4; eval '$x' }
371 sub db6 { my $x=4; eval '$x' }
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}}',
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
394 foreach my $k (keys %h) {
403 sub Foo {} print Foo(eval {});
404 pass('#20798 (used to dump core)');
406 # check for context in string eval
409 sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
411 my $code = q{ context() };
415 is("@r$c", 'AA', 'string eval list context');
417 is("$r$c", 'SS', 'string eval scalar context');
419 is("$c", 'V', 'string eval void context');
422 # [perl #34682] escaping an eval with last could coredump or dup output
426 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
429 is($got, "ok\n", 'eval and last');
431 # eval undef should be the same as eval "" barring any warnings
436 is($@, "", 'eval undef');
442 like($@, qr/^syntax error/, 'eval syntax error, no warnings');
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.
453 sub STORE { eval '('; $ok = 1 }
454 sub TIESCALAR { bless [] }
459 ::is($ok, 1, 'eval docatch');
462 # [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
465 eval { die "\x{a10d}"; };
469 cmp_ok($@, 'eq', "", 'length of $@ after eval');
470 cmp_ok(length $@, '==', 0, 'length of $@ after eval');
472 # Check if eval { 1 }; completely resets $@
474 skip_if_miniperl('no dynamic loading on miniperl, no Devel::Peek', 2);
476 skip('Devel::Peek was not built', 2)
477 unless $Config::Config{extensions} =~ /\bDevel\/Peek\b/;
479 my $tempfile = tempfile();
480 open $prog, ">", $tempfile or die "Can't create test file";
481 print $prog <<'END_EVAL_TEST';
486 print STDERR "******\n";
487 eval { die "\x{a10d}"; };
491 print STDERR "******\n";
492 print STDERR "Done\n";
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);
498 is($tombstone, "Done\n", 'Program completed successfully');
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';
507 is($second, $first, 'eval { 1 } completely resets $@');
510 # Test that "use feature" and other hint transmission in evals and s///ee
513 use feature qw(:5.10);
514 my $count_expected = ($^H & 0x20000) ? 2 : 1;
517 $s =~ s/a/$t = \%^H; qq( qq() );/ee;
518 is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110');
521 # make sure default arg eval only adds a hints hash once to entereval
525 is(eval, 33, 'argless eval without hints');
526 use feature qw(:5.10);
528 is(eval, 66, 'argless eval with hints');
532 # test that the CV compiled for the eval is freed by checking that no additional
533 # reference to outside lexicals are made.
535 is(Internals::SvREFCNT($x), 1, "originally only 1 reference");
537 is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
540 fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
546 fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
553 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
559 fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
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 { + } };
573 fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
574 use overload '""' => sub { '1;' };
581 eval 'my $do_something_with = $k';
584 "string eval leaves readonly lexicals readonly [perl #19135]";
588 fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H');
590 require re; re->import('/x'); # should only affect surrounding scope
592 print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
594 print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
597 print "ab" =~ /a b/ ? "ok\n" : "nokay\n";
602 BEGIN { eval 'require re; import re "/x"' }
603 ok "ab" =~ /a b/, 'eval does not localise %^H at run time';
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.
609 pass("phew! dodged the assertion after a parsing (not lexing) error");
613 local $ENV{PERL_DESTRUCT_LEVEL} = 1;
616 prog => 'BEGIN { $^H{foo} = bar }'
617 .'our %FIELDS; my main $x; eval q[$x->{foo}]',
620 qr/Unbalanced string table/,
621 'Errors in finalize_optree do not leak string eval op tree';
624 # [perl #114658] Line numbers at end of string eval
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
630 qq'Right line number for eval "$_"';
635 local $SIG{__WARN__} = sub { $w .= shift };
637 eval "\${\nfoobar\n} = 10; warn q{should be line 3}";
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'
645 sub _117941 { package _117941; eval '$a' }
646 delete $::{"_117941::"};
648 pass("eval in freed package does not crash");