path: root/t/op/eval.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    require './test.pl';
    set_up_inc('../lib');
}

plan(tests => 162);

eval 'pass();';

is($@, '');

eval "\$foo\n    = # this is a comment\n'ok 3';";
is($foo, 'ok 3');

eval "\$foo\n    = # this is a comment\n'ok 4\n';";
is($foo, "ok 4\n");

print eval '
$foo =;';		# this tests for a call through yyerror()
like($@, qr/line 2/);

print eval '$foo = /';	# this tests for a call through fatal()
like($@, qr/Search/);

is scalar(eval '++'), undef, 'eval syntax error in scalar context';
is scalar(eval 'die'), undef, 'eval run-time error in scalar context';
is +()=eval '++', 0, 'eval syntax error in list context';
is +()=eval 'die', 0, 'eval run-time error in list context';

is(eval '"ok 7\n";', "ok 7\n");

$foo = 5;
$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
$ans = eval $fact;
is($ans, 120, 'calculate a factorial with recursive evals');

$foo = 5;
$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
$ans = eval $fact;
is($ans, 120, 'calculate a factorial with recursive evals');

my $curr_test = curr_test();
my $tempfile = tempfile();
open(try,'>',$tempfile);
print try 'print "ok $curr_test\n";',"\n";
close try;

do "./$tempfile"; print $@;

# Test the singlequoted eval optimizer

$i = $curr_test + 1;
for (1..3) {
    eval 'print "ok ", $i++, "\n"';
}

$curr_test += 4;

eval {
    print "ok $curr_test\n";
    die sprintf "ok %d\n", $curr_test + 2;
    1;
} || printf "ok %d\n$@", $curr_test + 1;

curr_test($curr_test + 3);

# check whether eval EXPR determines value of EXPR correctly

{
  my @a = qw(a b c d);
  my @b = eval @a;
  is("@b", '4');
  is($@, '');

  my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
  my $b;
  @a = eval $a;
  is("@a", 'A');
  is(  $b, 'A');
  $_ = eval $a;
  is(  $b, 'S');
  eval $a;
  is(  $b, 'V');

  $b = 'wrong';
  $x = sub {
     my $b = "right";
     is(eval('"$b"'), $b);
  };
  &$x();
}

{
  my $b = 'wrong';
  my $X = sub {
     my $b = "right";
     is(eval('"$b"'), $b);
  };
  &$X();
}

# check navigation of multiple eval boundaries to find lexicals

my $x = 'aa';
eval <<'EOT'; die if $@;
  print "# $x\n";	# clone into eval's pad
  sub do_eval1 {
     eval $_[0]; die if $@;
  }
EOT
do_eval1('is($x, "aa")');
$x++;
do_eval1('eval q[is($x, "ab")]');
$x++;
do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()');
$x++;

# calls from within eval'' should clone outer lexicals

eval <<'EOT'; die if $@;
  sub do_eval2 {
     eval $_[0]; die if $@;
  }
do_eval2('is($x, "ad")');
$x++;
do_eval2('eval q[is($x, "ae")]');
$x++;
do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()');
EOT

# calls outside eval'' should NOT clone lexicals from called context

$main::ok = 'not ok';
my $ok = 'ok';
eval <<'EOT'; die if $@;
  # $x unbound here
  sub do_eval3 {
     eval $_[0]; die if $@;
  }
EOT
{
    my $ok = 'not ok';
    do_eval3('is($ok, q{ok})');
    do_eval3('eval q[is($ok, q{ok})]');
    do_eval3('sub { eval q[is($ok, q{ok})] }->()');
}

{
    my $x = curr_test();
    my $got;
    sub recurse {
	my $l = shift;
	if ($l < $x) {
	    ++$l;
	    eval 'print "# level $l\n"; recurse($l);';
	    die if $@;
	}
	else {
	    $got = "ok $l";
	}
    }
    local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ };
    recurse(curr_test() - 5);

    is($got, "ok $x",
       "recursive subroutine-call inside eval'' see its own lexicals");
}


eval <<'EOT';
  sub create_closure {
    my $self = shift;
    return sub {
       return $self;
    };
  }
EOT
is(create_closure("good")->(), "good",
   'closures created within eval bind correctly');

$main::r = "good";
sub terminal { eval '$r . q{!}' }
is(do {
   my $r = "bad";
   eval 'terminal($r)';
}, 'good!', 'lexical search terminates correctly at subroutine boundary');

{
    # Have we cured panic which occurred with require/eval in die handler ?
    local $SIG{__DIE__} = sub { eval {1}; die shift };
    eval { die "wham_eth\n" };
    is($@, "wham_eth\n");
}

{
    my $c = eval "(1,2)x10";
    is($c, '2222222222', 'scalar eval"" pops stack correctly');
}

# return from eval {} should clear $@ correctly
{
    my $status = eval {
	eval { die };
	print "# eval { return } test\n";
	return; # removing this changes behavior
    };
    is($@, '', 'return from eval {} should clear $@ correctly');
}

# ditto for eval ""
{
    my $status = eval q{
	eval q{ die };
	print "# eval q{ return } test\n";
	return; # removing this changes behavior
    };
    is($@, '', 'return from eval "" should clear $@ correctly');
}

# Check that eval catches bad goto calls
#   (BUG ID 20010305.003 (#5963))
{
    eval {
	eval { goto foo; };
	like($@, qr/Can't "goto" into the middle of a foreach loop/,
	     'eval catches bad goto calls');
	last;
	foreach my $i (1) {
	    foo: fail('jumped into foreach');
	}
    };
    fail("Outer eval didn't execute the last");
    diag($@);
}

# Make sure that "my $$x" is forbidden
# 20011224 MJD
{
    foreach (qw($$x @$x %$x $$$x)) {
	eval 'my ' . $_;
	isnt($@, '', "my $_ is forbidden");
    }
}

{
    $@ = 5;
    eval q{};
    cmp_ok(length $@, '==', 0, '[ID 20020623.002 (#9721)] eval "" doesn\'t clear $@');
}

# DAPM Nov-2002. Perl should now capture the full lexical context during
# evals.

$::zzz = $::zzz = 0;
my $zzz = 1;

eval q{
    sub fred1 {
	eval q{ is(eval '$zzz', 1); }
    }
    fred1(47);
    { my $zzz = 2; fred1(48) }
};

eval q{
    sub fred2 {
	is(eval('$zzz'), 1);
    }
};
fred2(49);
{ my $zzz = 2; fred2(50) }

# sort() starts a new context stack. Make sure we can still find
# the lexically enclosing sub

sub do_sort {
    my $zzz = 2;
    my @a = sort
	    { is(eval('$zzz'), 2); $a <=> $b }
	    2, 1;
}
do_sort();

# more recursion and lexical scope leak tests

eval q{
    my $r = -1;
    my $yyy = 9;
    sub fred3 {
	my $l = shift;
	my $r = -2;
	return 1 if $l < 1;
	return 0 if eval '$zzz' != 1;
	return 0 if       $yyy  != 9;
	return 0 if eval '$yyy' != 9;
	return 0 if eval '$l' != $l;
	return $l * fred3($l-1);
    }
    my $r = fred3(5);
    is($r, 120);
    $r = eval'fred3(5)';
    is($r, 120);
    $r = 0;
    eval '$r = fred3(5)';
    is($r, 120);
    $r = 0;
    { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
    is($r, 120);
};
my $r = fred3(5);
is($r, 120);
$r = eval'fred3(5)';
is($r, 120);
$r = 0;
eval'$r = fred3(5)';
is($r, 120);
$r = 0;
{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
is($r, 120);

# check that goto &sub within evals doesn't leak lexical scope

my $yyy = 2;

sub fred4 { 
    my $zzz = 3;
    is($zzz, 3);
    is(eval '$zzz', 3);
    is(eval '$yyy', 2);
}

eval q{
    fred4();
    sub fred5 {
	my $zzz = 4;
	is($zzz, 4);
	is(eval '$zzz', 4);
	is(eval '$yyy', 2);
	goto &fred4;
    }
    fred5();
};
fred5();
{ my $yyy = 88; my $zzz = 99; fred5(); }
eval q{ my $yyy = 888; my $zzz = 999; fred5(); };

{
   $eval = eval 'sub { eval "sub { %S }" }';
   $eval->({});
   pass('[perl #9728] used to dump core');
}

# evals that appear in the DB package should see the lexical scope of the
# thing outside DB that called them (usually the debugged code), rather
# than the usual surrounding scope

our $x = 1;
{
    my $x=2;
    sub db1	{ $x; eval '$x' }
    sub DB::db2	{ $x; eval '$x' }
    package DB;
    sub db3	{ eval '$x' }
    sub DB::db4	{ eval '$x' }
    sub db5	{ my $x=4; eval '$x' }
    package main;
    sub db6	{ my $x=4; eval '$x' }
}
{
    my $x = 3;
    is(db1(),      2);
    is(DB::db2(),  2);
    is(DB::db3(),  3);
    is(DB::db4(),  3);
    is(DB::db5(),  3);
    is(db6(),      4);
}

# [perl #19022] used to end up with shared hash warnings
# The program should generate no output, so anything we see is on stderr
my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
		   stderr => 1);
is ($got, '');

# And a buggy way of fixing #19022 made this fail - $k became undef after the
# eval for a build with copy on write
{
  my %h;
  $h{a}=1;
  foreach my $k (keys %h) {
    is($k, 'a');

    eval "\$k";

    is($k, 'a');
  }
}

sub Foo {} print Foo(eval {});
pass('#20798 (used to dump core)');

# check for context in string eval
{
  my(@r,$r,$c);
  sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }

  my $code = q{ context() };
  @r = qw( a b );
  $r = 'ab';
  @r = eval $code;
  is("@r$c", 'AA', 'string eval list context');
  $r = eval $code;
  is("$r$c", 'SS', 'string eval scalar context');
  eval $code;
  is("$c", 'V', 'string eval void context');
}

# [perl #34682] escaping an eval with last could coredump or dup output

$got = runperl (
    prog => 
    'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
stderr => 1);

is($got, "ok\n", 'eval and last');

# eval undef should be the same as eval "" barring any warnings

{
    local $@ = "foo";
    eval undef;
    is($@, "", 'eval undef');
}

{
    no warnings;
    eval "&& $b;";
    like($@, qr/^syntax error/, 'eval syntax error, no warnings');
}

# a syntax error in an eval called magically (eg via tie or overload)
# resulted in an assertion failure in S_docatch, since doeval_compile had
# already popped the EVAL context due to the failure, but S_docatch
# expected the context to still be there.

{
    my $ok  = 0;
    package Eval1;
    sub STORE { eval '('; $ok = 1 }
    sub TIESCALAR { bless [] }

    my $x;
    tie $x, bless [];
    $x = 1;
    ::is($ok, 1, 'eval docatch');
}

# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
# length $@ 
$@ = "";
eval { die "\x{a10d}"; };
$_ = length $@;
eval { 1 };

cmp_ok($@, 'eq', "", 'length of $@ after eval');
cmp_ok(length $@, '==', 0, 'length of $@ after eval');

# Check if eval { 1 }; completely resets $@
SKIP: {
    skip_if_miniperl('no dynamic loading on miniperl, no Devel::Peek', 2);
    require Config;
    skip('Devel::Peek was not built', 2)
	unless $Config::Config{extensions} =~ /\bDevel\/Peek\b/;

    my $tempfile = tempfile();
    open $prog, ">", $tempfile or die "Can't create test file";
    print $prog <<'END_EVAL_TEST';
    use Devel::Peek;
    $! = 0;
    $@ = $!;
    Dump($@);
    print STDERR "******\n";
    eval { die "\x{a10d}"; };
    $_ = length $@;
    eval { 1 };
    Dump($@);
    print STDERR "******\n";
    print STDERR "Done\n";
END_EVAL_TEST
    close $prog or die "Can't close $tempfile: $!";
    my $got = runperl(progfile => $tempfile, stderr => 1);
    my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got);

    is($tombstone, "Done\n", 'Program completed successfully');

    $first =~ s/p?[NI]OK,//g;
    s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
    s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
    # Dump may double newlines through pipes, though not files
    # which is what this test used to use.
    $second =~ s/ IV = 0\n\n/ IV = 0\n/ if $^O eq 'VMS';

    is($second, $first, 'eval { 1 } completely resets $@');
}

# Test that "use feature" and other hint transmission in evals and s///ee
# don't leak memory
{
    use feature qw(:5.10);
    my $count_expected = ($^H & 0x20000) ? 2 : 1;
    my $t;
    my $s = "a";
    $s =~ s/a/$t = \%^H;  qq( qq() );/ee;
    refcount_is $t, $count_expected, 'RT 63110';
}

# make sure default arg eval only adds a hints hash once to entereval
#
{
    local $_ = "21+12";
    is(eval, 33, 'argless eval without hints');
    use feature qw(:5.10);
    local $_ = "42+24";
    is(eval, 66, 'argless eval with hints');
}

{
    # test that the CV compiled for the eval is freed by checking that no additional 
    # reference to outside lexicals are made.
    my $x;
    refcount_is \$x, 1+1, "originally only 1 reference"; # + 1 to account for the ref here
    eval '$x';
    refcount_is \$x, 1+1, "execution eval doesn't create new references"; # + 1 the same
}

fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
$::{'@'}='';
eval {};
print "ok\n";
EOP

fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
eval {
    $::{'@'}='';
};
print "ok\n";
EOP

fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
$::{'@'}=\3;
eval {};
print "ok\n";
EOP

fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
eval {
    $::{'@'}=\3;
};
print "ok\n";
EOP

    fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals');
# localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ
BEGIN { $^H |= 0x00020000 }
eval q{ eval { + } };
print "ok\n";
EOP

fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start');
use overload '""'  => sub { '1;' };
my $ov = bless [];
eval $ov;
print "ok\n";
EOP

for my $k (!0) {
  eval 'my $do_something_with = $k';
  eval { $k = 'mon' };
  is "a" =~ /a/, "1",
    "string eval leaves readonly lexicals readonly [perl #19135]";
}

# [perl #68750]
fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H');
  BEGIN {
    require re; re->import('/x'); # should only affect surrounding scope
    eval '
      print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
      use re "/m";
      print "a b" =~ /a b/ ? "ok\n" : "nokay\n";
   ';
  }
  print "ab" =~ /a b/ ? "ok\n" : "nokay\n";
EOP

# [perl #70151]
{
    BEGIN { eval 'require re; import re "/x"' }
    ok "ab" =~ /a b/, 'eval does not localise %^H at run time';
}

# The fix for perl #70151 caused an assertion failure that broke
# SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails.
eval(q|""!=!~//|);
pass("phew! dodged the assertion after a parsing (not lexing) error");

# [perl #111462]
{
   local $ENV{PERL_DESTRUCT_LEVEL} = 1;
   unlike
     runperl(
      prog => 'BEGIN { $^H{foo} = bar }'
             .'our %FIELDS; my main $x; eval q[$x->{foo}]',
      stderr => 1,
     ),
     qr/Unbalanced string table/,
    'Errors in finalize_optree do not leak string eval op tree';
}

# [perl #114658] Line numbers at end of string eval
for("{;", "{") {
    eval $_; is $@ =~ s/eval \d+/eval 1/rag, <<'EOE',
Missing right curly or square bracket at (eval 1) line 1, at end of line
syntax error at (eval 1) line 1, at EOF
EOE
	qq'Right line number for eval "$_"';
}

{
    my $w;
    local $SIG{__WARN__} = sub { $w .= shift };

    eval "\${\nfoobar\n} = 10; warn q{should be line 3}";
    is(
        $w =~ s/eval \d+/eval 1/ra,
        "should be line 3 at (eval 1) line 3.\n",
        'eval qq{\${\nfoo\n}; warn} updates the line number correctly'
    );
}

sub _117941 { package _117941; eval '$a' }
delete $::{"_117941::"};
_117941();
pass("eval in freed package does not crash");

# eval is supposed normally to clear $@ on success

{
    $@ = 1;
    eval q{$@ = 2};
    ok(!$@, 'eval clearing $@');
}

# RT #127786
# this used to give an assertion failure

{
    package DB {
        sub f127786 { eval q/\$s/ }
    }
    my $s;
    sub { $s; DB::f127786}->();
    pass("RT #127786");
}

# Late calling of destructors overwriting $@.
# When leaving an eval scope (either by falling off the end or dying),
# we must ensure that any temps are freed before the end of the eval
# leave: in particular before $@ is set (to either "" or the error),
# because otherwise the tmps freeing may call a destructor which
# will change $@ (e.g. due to a successful eval) *after* its been set.
# Some extra nested scopes are included in the tests to ensure they don't
# affect the tmps freeing.

{
    package TMPS;
    sub DESTROY { eval { die "died in DESTROY"; } } # alters $@

    eval { { 1; { 1; bless []; } } };
    ::is ($@, "", "FREETMPS: normal try exit");

    eval q{ { 1; { 1; bless []; } } };
    ::is ($@, "", "FREETMPS: normal string eval exit");

    eval { { 1; { 1; return bless []; } } };
    ::is ($@, "", "FREETMPS: return try exit");

    eval q{ { 1; { 1; return bless []; } } };
    ::is ($@, "", "FREETMPS: return string eval exit");

    eval { { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } };
    ::like ($@, qr/die in eval/, "FREETMPS: die try exit");

    eval q{ { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } };
    ::like ($@, qr/die in eval/, "FREETMPS: die eval string exit");
}

{
    local ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}= 0;
    my ($x, $ok);
    $x = 0;
    $ok= eval 'BEGIN { $x++ } 1';
    ::ok(!$ok,'${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 0 blocks BEGIN blocks entirely');
    ::like($@,qr/Too many nested BEGIN blocks, maximum of 0 allowed/,
        'Blocked BEGIN results in expected error');
    ::is($x,0,'BEGIN really did nothing');

    ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}= 2;
    $ok= eval 'sub f { my $n= shift; eval q[BEGIN { $x++; f($n-1) if $n>0 } 1] or die $@ } f(3); 1';
    ::ok(!$ok,'${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 2 blocked three nested BEGIN blocks');
    ::like($@,qr/Too many nested BEGIN blocks, maximum of 2 allowed/,
        'Blocked BEGIN results in expected error');
    ::is($x,2,'BEGIN really did nothing');

}

{
    # make sure that none of these segfault.
    foreach my $line (
        'eval "UNITCHECK { eval q(UNITCHECK { die; }); print q(A-) }";',
        'eval "UNITCHECK { eval q(BEGIN     { die; }); print q(A-) }";',
        'eval "BEGIN     { eval q(UNITCHECK { die; }); print q(A-) }";',
        'CHECK     { eval "]" } print q"A-";',
        'INIT      { eval "]" } print q"A-";',
        'UNITCHECK { eval "]" } print q"A-";',
        'BEGIN     { eval "]" } print q"A-";',
        'INIT      { eval q(UNITCHECK { die; } print 0;); print q(A-); }',
    ) {
        fresh_perl_is($line . ' print "ok";', "A-ok", {}, "No segfault: $line");

        # sort blocks are somewhat special and things that work in normal blocks
        # can blow up in sort blocks, so test these constructs specially.
        my $sort_line= 'my @x= sort { ' . $line . ' } 1,2;';
        fresh_perl_is($sort_line . ' print "ok";', "A-ok", {},
            "No segfault inside sort: $sort_line");
    }
}