X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Feval.t;h=42a71e259396be0c641b3a0619f97c6c2c03fbdf;hb=2986a63f7e513cf37f46db9f211b77071260031f;hp=9368281d5b66028ddee75e946d169c8cd8e90dc1;hpb=fc360e464b2c0ad9f690711276bbd836ab5c39af;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/eval.t b/t/op/eval.t
index 9368281..42a71e2 100755
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -1,8 +1,6 @@
 #!./perl
 
-# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $
-
-print "1..23\n";
+print "1..41\n";
 
 eval 'print "ok 1\n";';
 
@@ -39,7 +37,7 @@ open(try,'>Op.eval');
 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
 
@@ -79,3 +77,147 @@ eval {
   };
   &$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 $@;
+}