#!./perl
-# $RCSfile: eval.t,v $$Revision: 4.0.1.1 $$Date: 91/11/05 18:43:19 $
-
-print "1..16\n";
+print "1..41\n";
eval 'print "ok 1\n";';
print $foo;
print eval '
-$foo ='; # this tests for a call through yyerror()
+$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()
print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
close try;
-do 'Op.eval'; print $@;
+do './Op.eval'; print $@;
# Test the singlequoted eval optimizer
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::x = 'ok';
+eval <<'EOT'; die if $@;
+ # $x unbound here
+ sub do_eval3 {
+ eval $_[0]; die if $@;
+ }
+EOT
+do_eval3('print "$x ' . $x . '\n"');
+$x++;
+do_eval3('eval q[print "$x ' . $x . '\n"]');
+$x++;
+do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()');
+$x++;
+
+# 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 $@;
+}