[perl5.git] / t / op / eval.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

print "1..105\n";

eval 'print "ok 1\n";';

if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}

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

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

print eval '
$foo =;';		# this tests for a call through yyerror()
if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}

print eval '$foo = /';	# this tests for a call through fatal()
if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}

print eval '"ok 7\n";';

# calculate a factorial with recursive evals

$foo = 5;
$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
$ans = eval $fact;
if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}

$foo = 5;
$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
$ans = eval $fact;
if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}

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

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

# Test the singlequoted eval optimizer

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

eval {
    print "ok 14\n";
    die "ok 16\n";
    1;
} || print "ok 15\n$@";

# check whether eval EXPR determines value of EXPR correctly

{
  my @a = qw(a b c d);
  my @b = eval @a;
  print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
  print $@ ? "not ok 18\n" : "ok 18\n";

  my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
  my $b;
  @a = eval $a;
  print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
  print   $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
  $_ = eval $a;
  print   $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
  eval $a;
  print   $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";

  $b = 'wrong';
  $x = sub {
     my $b = "right";
     print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
  };
  &$x();
}

my $b = 'wrong';
my $X = sub {
   my $b = "right";
   print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
};
&$X();


# check navigation of multiple eval boundaries to find lexicals

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

# calls from within eval'' should clone outer lexicals

eval <<'EOT'; die if $@;
  sub do_eval2 {
     eval $_[0]; die if $@;
  }
do_eval2('print "ok $x\n"');
$x++;
do_eval2('eval q[print "ok $x\n"]');
$x++;
do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
$x++;
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('print "$ok ' . $x++ . '\n"');
    do_eval3('eval q[print "$ok ' . $x++ . '\n"]');
    do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()');
}

# can recursive subroutine-call inside eval'' see its own lexicals?
sub recurse {
  my $l = shift;
  if ($l < $x) {
     ++$l;
     eval 'print "# level $l\n"; recurse($l);';
     die if $@;
  }
  else {
    print "ok $l\n";
  }
}
{
  local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
  recurse($x-5);
}
$x++;

# do closures created within eval bind correctly?
eval <<'EOT';
  sub create_closure {
    my $self = shift;
    return sub {
       print $self;
    };
  }
EOT
create_closure("ok $x\n")->();
$x++;

# does lexical search terminate correctly at subroutine boundary?
$main::r = "ok $x\n";
sub terminal { eval 'print $r' }
{
   my $r = "not ok $x\n";
   eval 'terminal($r)';
}
$x++;

# Have we cured panic which occurred with require/eval in die handler ?
$SIG{__DIE__} = sub { eval {1}; die shift }; 
eval { die "ok ".$x++,"\n" }; 
print $@;

# does scalar eval"" pop stack correctly?
{
    my $c = eval "(1,2)x10";
    print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
    $x++;
}

# return from eval {} should clear $@ correctly
{
    my $status = eval {
	eval { die };
	print "# eval { return } test\n";
	return; # removing this changes behavior
    };
    print "not " if $@;
    print "ok $x\n";
    $x++;
}

# ditto for eval ""
{
    my $status = eval q{
	eval q{ die };
	print "# eval q{ return } test\n";
	return; # removing this changes behavior
    };
    print "not " if $@;
    print "ok $x\n";
    $x++;
}

# Check that eval catches bad goto calls
#   (BUG ID 20010305.003)
{
    eval {
	eval { goto foo; };
	print ($@ ? "ok 41\n" : "not ok 41\n");
	last;
	foreach my $i (1) {
	    foo: print "not ok 41\n";
	    print "# jumped into foreach\n";
	}
    };
    print "not ok 41\n" if $@;
}

# Make sure that "my $$x" is forbidden
# 20011224 MJD
{
  eval q{my $$x};
  print $@ ? "ok 42\n" : "not ok 42\n";
  eval q{my @$x};
  print $@ ? "ok 43\n" : "not ok 43\n";
  eval q{my %$x};
  print $@ ? "ok 44\n" : "not ok 44\n";
  eval q{my $$$x};
  print $@ ? "ok 45\n" : "not ok 45\n";
}

# [ID 20020623.002] eval "" doesn't clear $@
{
    $@ = 5;
    eval q{};
    print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
}

# 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{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
    }
    fred1(47);
    { my $zzz = 2; fred1(48) }
};

eval q{
    sub fred2 {
	print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
    }
};
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
	    { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $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);
    print $r == 120 ? 'ok' : 'not ok', " 52\n";
    $r = eval'fred3(5)';
    print $r == 120 ? 'ok' : 'not ok', " 53\n";
    $r = 0;
    eval '$r = fred3(5)';
    print $r == 120 ? 'ok' : 'not ok', " 54\n";
    $r = 0;
    { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
    print $r == 120 ? 'ok' : 'not ok', " 55\n";
};
my $r = fred3(5);
print $r == 120 ? 'ok' : 'not ok', " 56\n";
$r = eval'fred3(5)';
print $r == 120 ? 'ok' : 'not ok', " 57\n";
$r = 0;
eval'$r = fred3(5)';
print $r == 120 ? 'ok' : 'not ok', " 58\n";
$r = 0;
{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
print $r == 120 ? 'ok' : 'not ok', " 59\n";

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

my $yyy = 2;

my $test = 60;
sub fred4 { 
    my $zzz = 3;
    print +($zzz == 3  && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
    $test++;
    print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
    $test++;
}

eval q{
    fred4();
    sub fred5 {
	my $zzz = 4;
	print +($zzz == 4  && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
	$test++;
	print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
	$test++;
	goto &fred4;
    }
    fred5();
};
fred5();
{ my $yyy = 88; my $zzz = 99; fred5(); }
eval q{ my $yyy = 888; my $zzz = 999; fred5(); };

# [perl #9728] used to dump core
{
   $eval = eval 'sub { eval "sub { %S }" }';
   $eval->({});
   print "ok $test\n";
   $test++;
}

# 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

$test=79;
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;
    print db1()     == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
    print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
    print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
    print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
    print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
    print db6()     == 4 ? 'ok' : 'not ok', " $test\n"; $test++;
}
require './test.pl';
$NO_ENDING = 1;
# [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);

if ($got eq '') {
  print "ok $test\n";
} else {
  print "not ok $test\n";
  _diag ("# Got '$got'\n");
}
$test++;

# 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) {
    if (defined $k and $k eq 'a') {
      print "ok $test\n";
    } else {
      print "not $test # got ", _q ($k), "\n";
    }
    $test++;

    eval "\$k";

    if (defined $k and $k eq 'a') {
      print "ok $test\n";
    } else {
      print "not $test # got ", _q ($k), "\n";
    }
    $test++;
  }
}

sub Foo {} print Foo(eval {});
print "ok ",$test++," - #20798 (used to dump core)\n";

# 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;
  print "@r$c" eq 'AA' ? "ok " : "# '@r$c' ne 'AA'\nnot ok ", $test++, "\n";
  $r = eval $code;
  print "$r$c" eq 'SS' ? "ok " : "# '$r$c' ne 'SS'\nnot ok ", $test++, "\n";
  eval $code;
  print   $c   eq 'V'  ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n";
}

# [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);

print "not " unless $got eq "ok\n";
print "ok $test - eval and last\n"; $test++;

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

{
    local $@ = "foo";
    eval undef;
    print "not " unless $@ eq "";
    print "ok $test # eval undef \n"; $test++;
}

{
    no warnings;
    eval "/ /a;";
    print "not " unless $@ =~ /^syntax error/;
    print "ok $test # eval syntax error, no warnings \n"; $test++;
}


# a syntax error in an eval called magically 9eg vie tie or overload)
# resulted in an assertion failure in S_docatch, since doeval had already
# poppedthe 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;
    print "not " unless $ok;
    print "ok $test # eval docatch \n"; $test++;
}


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

print "not " if ($@ ne "");
print "ok $test # length of \$@ after eval\n"; $test++;

print "not " if (length $@ != 0);
print "ok $test # length of \$@ after eval\n"; $test++;

# Check if eval { 1 }; compeltly resets $@
if (eval "use Devel::Peek; 1;") {
  $tempfile = tempfile();
  $outfile = tempfile();
  open PROG, ">", $tempfile or die "Can't create test file";
  my $prog = <<'END_EVAL_TEST';
    use Devel::Peek;
    $! = 0;
    $@ = $!;
    my $ok = 0;
    open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
    if (open(OUT, '>', '@@@@')) {
      open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
      Dump($@);
      print STDERR "******\n";
      eval { die "\x{a10d}"; };
      $_ = length $@;
      eval { 1 };
      Dump($@);
      open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
      close(OUT);
      if (open(IN, '<', '@@@@')) {
        local $/;
        my $in = <IN>;
        my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2);
        $first =~ s/,pNOK//;
        $ok = 1 if ($first eq $second);
      }
    }

    print $ok;
END_EVAL_TEST
    $prog =~ s/\@\@\@\@/$outfile/g;
    print PROG $prog;
   close PROG;

   my $ok = runperl(progfile => $tempfile);
   print "not " unless $ok;
   print "ok $test # eval { 1 } completly resets \$@\n";
}
else {
  print "ok $test # skipped - eval { 1 } completly resets \$@\n";
}
$test++;

# 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;
    print "not " if Internals::SvREFCNT(%$t) != $count_expected;
    print "ok $test - RT 63110\n";
    $test++;
}

curr_test($test);

{
    # test that the CV compiled for the eval is freed by checking that no additional 
    # reference to outside lexicals are made.
    my $x;
    is(Internals::SvREFCNT($x), 1, "originally only 1 referece");
    eval '$x';
    is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
}

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
Commit	Line	Data
a559c259 LW	1	#!./perl
a559c259 LW	2
7e736055 HS	3	BEGIN {
	4	chdir 't' if -d 't';
	5	@INC = '../lib';
1c25d394	6	require './test.pl';
7e736055 HS	7	}
7e736055 HS	8
3b9d46a3	9	print "1..105\n";
a559c259 LW	10
	11	eval 'print "ok 1\n";';
	12
	13	if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
	14
	15	eval "\$foo\n = # this is a comment\n'ok 3';";
	16	print $foo,"\n";
	17
	18	eval "\$foo\n = # this is a comment\n'ok 4\n';";
	19	print $foo;
	20
378cc40b	21	print eval '
79072805	22	$foo =;'; # this tests for a call through yyerror()
a559c259 LW	23	if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
a559c259 LW	24
378cc40b	25	print eval '$foo = /'; # this tests for a call through fatal()
a559c259	26	if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
378cc40b LW	27
	28	print eval '"ok 7\n";';
	29
	30	# calculate a factorial with recursive evals
	31
	32	$foo = 5;
	33	$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
	34	$ans = eval $fact;
	35	if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
	36
	37	$foo = 5;
a687059c	38	$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
378cc40b LW	39	$ans = eval $fact;
	40	if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
	41
1c25d394 NC	42	my $tempfile = tempfile();
	43	open(try,'>',$tempfile);
	44	print try 'print "ok 10\n";',"\n";
378cc40b LW	45	close try;
378cc40b LW	46
1c25d394	47	do "./$tempfile"; print $@;
99b89507 LW	48
	49	# Test the singlequoted eval optimizer
	50
	51	$i = 11;
	52	for (1..3) {
	53	eval 'print "ok ", $i++, "\n"';
	54	}
	55
	56	eval {
	57	print "ok 14\n";
	58	die "ok 16\n";
	59	1;
	60	} \|\| print "ok 15\n$@";
	61
c7cc6f1c GS	62	# check whether eval EXPR determines value of EXPR correctly
	63
	64	{
	65	my @a = qw(a b c d);
	66	my @b = eval @a;
	67	print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
	68	print $@ ? "not ok 18\n" : "ok 18\n";
	69
	70	my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
	71	my $b;
	72	@a = eval $a;
	73	print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
	74	print $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
	75	$_ = eval $a;
	76	print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
	77	eval $a;
	78	print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
fc360e46 AB	79
	80	$b = 'wrong';
	81	$x = sub {
	82	my $b = "right";
	83	print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
	84	};
	85	&$x();
c7cc6f1c	86	}
155fc61f GS	87
	88	my $b = 'wrong';
	89	my $X = sub {
	90	my $b = "right";
	91	print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
	92	};
	93	&$X();
	94
	95
	96	# check navigation of multiple eval boundaries to find lexicals
	97
	98	my $x = 25;
	99	eval <<'EOT'; die if $@;
0a00efa0 GS	100	print "# $x\n"; # clone into eval's pad
0a00efa0 GS	101	sub do_eval1 {
155fc61f GS	102	eval $_[0]; die if $@;
	103	}
	104	EOT
0a00efa0	105	do_eval1('print "ok $x\n"');
155fc61f	106	$x++;
0a00efa0	107	do_eval1('eval q[print "ok $x\n"]');
155fc61f	108	$x++;
b318f128	109	do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0 GS	110	$x++;
	111
	112	# calls from within eval'' should clone outer lexicals
	113
	114	eval <<'EOT'; die if $@;
	115	sub do_eval2 {
	116	eval $_[0]; die if $@;
	117	}
	118	do_eval2('print "ok $x\n"');
	119	$x++;
	120	do_eval2('eval q[print "ok $x\n"]');
	121	$x++;
b318f128	122	do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
0a00efa0 GS	123	$x++;
	124	EOT
	125
	126	# calls outside eval'' should NOT clone lexicals from called context
	127
a3985cdc DM	128	$main::ok = 'not ok';
a3985cdc DM	129	my $ok = 'ok';
0a00efa0 GS	130	eval <<'EOT'; die if $@;
	131	# $x unbound here
	132	sub do_eval3 {
	133	eval $_[0]; die if $@;
	134	}
	135	EOT
a3985cdc DM	136	{
	137	my $ok = 'not ok';
	138	do_eval3('print "$ok ' . $x++ . '\n"');
	139	do_eval3('eval q[print "$ok ' . $x++ . '\n"]');
	140	do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()');
	141	}
6b35e009 GS	142
	143	# can recursive subroutine-call inside eval'' see its own lexicals?
	144	sub recurse {
	145	my $l = shift;
	146	if ($l < $x) {
	147	++$l;
	148	eval 'print "# level $l\n"; recurse($l);';
	149	die if $@;
	150	}
	151	else {
	152	print "ok $l\n";
	153	}
	154	}
	155	{
	156	local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
	157	recurse($x-5);
	158	}
33b8ce05 GS	159	$x++;
	160
	161	# do closures created within eval bind correctly?
	162	eval <<'EOT';
	163	sub create_closure {
	164	my $self = shift;
	165	return sub {
	166	print $self;
	167	};
	168	}
	169	EOT
	170	create_closure("ok $x\n")->();
2680586e GS	171	$x++;
	172
	173	# does lexical search terminate correctly at subroutine boundary?
	174	$main::r = "ok $x\n";
	175	sub terminal { eval 'print $r' }
	176	{
	177	my $r = "not ok $x\n";
	178	eval 'terminal($r)';
	179	}
	180	$x++;
	181
a7c6d244 NIS	182	# Have we cured panic which occurred with require/eval in die handler ?
	183	$SIG{__DIE__} = sub { eval {1}; die shift };
	184	eval { die "ok ".$x++,"\n" };
	185	print $@;
	186
a7ec2b44 GS	187	# does scalar eval"" pop stack correctly?
	188	{
	189	my $c = eval "(1,2)x10";
	190	print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
	191	$x++;
	192	}
b45de488 GS	193
	194	# return from eval {} should clear $@ correctly
	195	{
	196	my $status = eval {
	197	eval { die };
	198	print "# eval { return } test\n";
	199	return; # removing this changes behavior
	200	};
	201	print "not " if $@;
	202	print "ok $x\n";
	203	$x++;
	204	}
	205
	206	# ditto for eval ""
	207	{
	208	my $status = eval q{
	209	eval q{ die };
	210	print "# eval q{ return } test\n";
	211	return; # removing this changes behavior
	212	};
	213	print "not " if $@;
	214	print "ok $x\n";
	215	$x++;
	216	}
3b2447bc RH	217
	218	# Check that eval catches bad goto calls
	219	# (BUG ID 20010305.003)
	220	{
	221	eval {
	222	eval { goto foo; };
	223	print ($@ ? "ok 41\n" : "not ok 41\n");
	224	last;
	225	foreach my $i (1) {
	226	foo: print "not ok 41\n";
	227	print "# jumped into foreach\n";
	228	}
	229	};
	230	print "not ok 41\n" if $@;
	231	}
b6512f48 MJD	232
	233	# Make sure that "my $$x" is forbidden
	234	# 20011224 MJD
	235	{
	236	eval q{my $$x};
	237	print $@ ? "ok 42\n" : "not ok 42\n";
	238	eval q{my @$x};
	239	print $@ ? "ok 43\n" : "not ok 43\n";
	240	eval q{my %$x};
	241	print $@ ? "ok 44\n" : "not ok 44\n";
	242	eval q{my $$$x};
	243	print $@ ? "ok 45\n" : "not ok 45\n";
	244	}
16a5162e JH	245
	246	# [ID 20020623.002] eval "" doesn't clear $@
	247	{
	248	$@ = 5;
	249	eval q{};
	250	print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
	251	}
a3985cdc DM	252
	253	# DAPM Nov-2002. Perl should now capture the full lexical context during
	254	# evals.
	255
	256	$::zzz = $::zzz = 0;
	257	my $zzz = 1;
	258
	259	eval q{
	260	sub fred1 {
	261	eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
	262	}
	263	fred1(47);
	264	{ my $zzz = 2; fred1(48) }
	265	};
	266
	267	eval q{
	268	sub fred2 {
	269	print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
	270	}
	271	};
	272	fred2(49);
	273	{ my $zzz = 2; fred2(50) }
	274
	275	# sort() starts a new context stack. Make sure we can still find
	276	# the lexically enclosing sub
	277
	278	sub do_sort {
	279	my $zzz = 2;
	280	my @a = sort
	281	{ print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
	282	2, 1;
	283	}
	284	do_sort();
	285
	286	# more recursion and lexical scope leak tests
	287
	288	eval q{
	289	my $r = -1;
	290	my $yyy = 9;
	291	sub fred3 {
	292	my $l = shift;
	293	my $r = -2;
	294	return 1 if $l < 1;
	295	return 0 if eval '$zzz' != 1;
	296	return 0 if $yyy != 9;
	297	return 0 if eval '$yyy' != 9;
	298	return 0 if eval '$l' != $l;
	299	return $l * fred3($l-1);
	300	}
	301	my $r = fred3(5);
	302	print $r == 120 ? 'ok' : 'not ok', " 52\n";
	303	$r = eval'fred3(5)';
	304	print $r == 120 ? 'ok' : 'not ok', " 53\n";
	305	$r = 0;
	306	eval '$r = fred3(5)';
	307	print $r == 120 ? 'ok' : 'not ok', " 54\n";
	308	$r = 0;
	309	{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
	310	print $r == 120 ? 'ok' : 'not ok', " 55\n";
	311	};
	312	my $r = fred3(5);
	313	print $r == 120 ? 'ok' : 'not ok', " 56\n";
	314	$r = eval'fred3(5)';
	315	print $r == 120 ? 'ok' : 'not ok', " 57\n";
316	$r = 0;
317	eval'$r = fred3(5)';
318	print $r == 120 ? 'ok' : 'not ok', " 58\n";
319	$r = 0;
320	{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
321	print $r == 120 ? 'ok' : 'not ok', " 59\n";
322
323	# check that goto &sub within evals doesn't leak lexical scope
324
325	my $yyy = 2;
326
327	my $test = 60;
328	sub fred4 {
329	my $zzz = 3;
330	print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
331	$test++;
332	print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
333	$test++;
334	}
335
336	eval q{
337	fred4();
338	sub fred5 {
339	my $zzz = 4;
340	print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
341	$test++;
342	print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
343	$test++;
344	goto &fred4;
345	}
346	fred5();
347	};
348	fred5();
349	{ my $yyy = 88; my $zzz = 99; fred5(); }
e8cf733a	350	eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
a3985cdc	351
e8cf733a HS	352	# [perl #9728] used to dump core
	353	{
	354	$eval = eval 'sub { eval "sub { %S }" }';
	355	$eval->({});
7e736055 HS	356	print "ok $test\n";
7e736055 HS	357	$test++;
e8cf733a	358	}
a3985cdc	359
d819b83a DM	360	# evals that appear in the DB package should see the lexical scope of the
	361	# thing outside DB that called them (usually the debugged code), rather
	362	# than the usual surrounding scope
	363
	364	$test=79;
	365	our $x = 1;
	366	{
	367	my $x=2;
	368	sub db1 { $x; eval '$x' }
	369	sub DB::db2 { $x; eval '$x' }
	370	package DB;
	371	sub db3 { eval '$x' }
	372	sub DB::db4 { eval '$x' }
	373	sub db5 { my $x=4; eval '$x' }
	374	package main;
	375	sub db6 { my $x=4; eval '$x' }
	376	}
	377	{
	378	my $x = 3;
	379	print db1() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
	380	print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
	381	print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
	382	print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
	383	print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
	384	print db6() == 4 ? 'ok' : 'not ok', " $test\n"; $test++;
	385	}
7e736055 HS	386	require './test.pl';
	387	$NO_ENDING = 1;
	388	# [perl #19022] used to end up with shared hash warnings
	389	# The program should generate no output, so anything we see is on stderr
	390	my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
	391	stderr => 1);
	392
	393	if ($got eq '') {
	394	print "ok $test\n";
	395	} else {
	396	print "not ok $test\n";
	397	_diag ("# Got '$got'\n");
	398	}
	399	$test++;
	400
	401	# And a buggy way of fixing #19022 made this fail - $k became undef after the
	402	# eval for a build with copy on write
	403	{
	404	my %h;
	405	$h{a}=1;
	406	foreach my $k (keys %h) {
	407	if (defined $k and $k eq 'a') {
	408	print "ok $test\n";
	409	} else {
	410	print "not $test # got ", _q ($k), "\n";
	411	}
	412	$test++;
	413
	414	eval "\$k";
	415
	416	if (defined $k and $k eq 'a') {
	417	print "ok $test\n";
	418	} else {
	419	print "not $test # got ", _q ($k), "\n";
	420	}
	421	$test++;
	422	}
	423	}
77d32bb7 RGS	424
	425	sub Foo {} print Foo(eval {});
	426	print "ok ",$test++," - #20798 (used to dump core)\n";
f48583aa MHM	427
	428	# check for context in string eval
	429	{
	430	my(@r,$r,$c);
	431	sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
	432
	433	my $code = q{ context() };
	434	@r = qw( a b );
	435	$r = 'ab';
	436	@r = eval $code;
	437	print "@r$c" eq 'AA' ? "ok " : "# '@r$c' ne 'AA'\nnot ok ", $test++, "\n";
	438	$r = eval $code;
	439	print "$r$c" eq 'SS' ? "ok " : "# '$r$c' ne 'SS'\nnot ok ", $test++, "\n";
	440	eval $code;
	441	print $c eq 'V' ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n";
	442	}
6ab4a6ff DM	443
	444	# [perl #34682] escaping an eval with last could coredump or dup output
	445
	446	$got = runperl (
	447	prog =>
	448	'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
	449	stderr => 1);
	450
	451	print "not " unless $got eq "ok\n";
	452	print "ok $test - eval and last\n"; $test++;
	453
eb034824 DM	454	# eval undef should be the same as eval "" barring any warnings
	455
	456	{
	457	local $@ = "foo";
	458	eval undef;
	459	print "not " unless $@ eq "";
500960a6 RD	460	print "ok $test # eval undef \n"; $test++;
	461	}
	462
	463	{
	464	no warnings;
	465	eval "/ /a;";
	466	print "not " unless $@ =~ /^syntax error/;
	467	print "ok $test # eval syntax error, no warnings \n"; $test++;
eb034824 DM	468	}
eb034824 DM	469
410be5db DM	470
	471	# a syntax error in an eval called magically 9eg vie tie or overload)
	472	# resulted in an assertion failure in S_docatch, since doeval had already
	473	# poppedthe EVAL context due to the failure, but S_docatch expected the
	474	# context to still be there.
	475
	476	{
	477	my $ok = 0;
	478	package Eval1;
	479	sub STORE { eval '('; $ok = 1 }
	480	sub TIESCALAR { bless [] }
	481
	482	my $x;
	483	tie $x, bless [];
	484	$x = 1;
	485	print "not " unless $ok;
	486	print "ok $test # eval docatch \n"; $test++;
	487	}
	488
	489
8433848b B	490	# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
	491	# length $@
	492	$@ = "";
	493	eval { die "\x{a10d}"; };
	494	$_ = length $@;
	495	eval { 1 };
	496
	497	print "not " if ($@ ne "");
	498	print "ok $test # length of \$@ after eval\n"; $test++;
	499
	500	print "not " if (length $@ != 0);
	501	print "ok $test # length of \$@ after eval\n"; $test++;
	502
	503	# Check if eval { 1 }; compeltly resets $@
	504	if (eval "use Devel::Peek; 1;") {
1c25d394 NC	505	$tempfile = tempfile();
	506	$outfile = tempfile();
	507	open PROG, ">", $tempfile or die "Can't create test file";
	508	my $prog = <<'END_EVAL_TEST';
8433848b B	509	use Devel::Peek;
	510	$! = 0;
	511	$@ = $!;
	512	my $ok = 0;
	513	open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
1c25d394	514	if (open(OUT, '>', '@@@@')) {
8433848b B	515	open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
	516	Dump($@);
	517	print STDERR "******\n";
	518	eval { die "\x{a10d}"; };
	519	$_ = length $@;
	520	eval { 1 };
	521	Dump($@);
	522	open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
	523	close(OUT);
1c25d394	524	if (open(IN, '<', '@@@@')) {
8433848b B	525	local $/;
	526	my $in = <IN>;
	527	my ($first, $second) = split (/\\\\\\\n/, $in, 2);
	528	$first =~ s/,pNOK//;
	529	$ok = 1 if ($first eq $second);
	530	}
	531	}
	532
	533	print $ok;
8433848b	534	END_EVAL_TEST
1c25d394 NC	535	$prog =~ s/\@\@\@\@/$outfile/g;
1c25d394 NC	536	print PROG $prog;
8433848b B	537	close PROG;
8433848b B	538
1c25d394	539	my $ok = runperl(progfile => $tempfile);
8433848b B	540	print "not " unless $ok;
8433848b B	541	print "ok $test # eval { 1 } completly resets \$@\n";
8433848b B	542	}
8433848b B	543	else {
5a1562d6	544	print "ok $test # skipped - eval { 1 } completly resets \$@\n";
8433848b	545	}
fa13de94	546	$test++;
410be5db	547
fa13de94 RGS	548	# Test that "use feature" and other hint transmission in evals and s///ee
	549	# don't leak memory
	550	{
	551	use feature qw(:5.10);
e8514a9e	552	my $count_expected = ($^H & 0x20000) ? 2 : 1;
fa13de94 RGS	553	my $t;
	554	my $s = "a";
	555	$s =~ s/a/$t = \%^H; qq( qq() );/ee;
e8514a9e	556	print "not " if Internals::SvREFCNT(%$t) != $count_expected;
fa13de94 RGS	557	print "ok $test - RT 63110\n";
	558	$test++;
	559	}
f5fa9033 NC	560
	561	curr_test($test);
	562
3b9d46a3 GG	563	{
	564	# test that the CV compiled for the eval is freed by checking that no additional
	565	# reference to outside lexicals are made.
	566	my $x;
	567	is(Internals::SvREFCNT($x), 1, "originally only 1 referece");
	568	eval '$x';
	569	is(Internals::SvREFCNT($x), 1, "execution eval doesn't create new references");
	570	}
	571
f5fa9033 NC	572	fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862');
	573	$::{'@'}='';
	574	eval {};
	575	print "ok\n";
	576	EOP
	577
	578	fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862');
	579	eval {
	580	$::{'@'}='';
	581	};
	582	print "ok\n";
	583	EOP
dfd167e9 NC	584
	585	fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
	586	$::{'@'}=\3;
	587	eval {};
	588	print "ok\n";
	589	EOP
	590
	591	fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862');
	592	eval {
	593	$::{'@'}=\3;
	594	};
	595	print "ok\n";
	596	EOP