X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fclosure.t;h=7d8df6a2cc44a430d9e3dc00b01853682113235e;hb=584420f022db57225e9644b9c6668ff9f567984a;hp=6a81a44f36ea862281cea9aa11b705dd71c12cb6;hpb=7dafbf5232bace07a044625a5a956b73da3928d5;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/closure.t b/t/op/closure.t
index 6a81a44..7d8df6a 100755
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -12,8 +12,9 @@ BEGIN {
 }
 
 use Config;
+require './test.pl'; # for runperl()
 
-print "1..181\n";
+print "1..187\n";
 
 my $test = 1;
 sub test (&) {
@@ -255,7 +256,7 @@ END_MARK_ONE
 
 	  $code .=  <<"END_MARK_TWO" if $nc_attempt;
     return if index(\$msg, 'will not stay shared') != -1;
-    return if index(\$msg, 'may be unavailable') != -1;
+    return if index(\$msg, 'is not available') != -1;
 END_MARK_TWO
 
 	  $code .= <<"END_MARK_THREE";		# Backwhack a lot!
@@ -446,8 +447,8 @@ END
 	      close READ2;
 	      open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
 	      open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
-	      exec './perl', '-w', '-'
-		or die "Can't exec ./perl: $!";
+	      exec which_perl(), '-w', '-'
+		or die "Can't exec perl: $!";
 	    } else {
 	      # Parent process here.
 	      close WRITE;
@@ -466,11 +467,7 @@ END
 	    my $errfile = "terr$$";  $errfile++ while -e $errfile;
 	    my @tmpfiles = ($cmdfile, $errfile);
 	    open CMD, ">$cmdfile"; print CMD $code; close CMD;
-	    my $cmd = (($^O eq 'VMS') ? "MCR $^X"
-		       : ($^O eq 'MSWin32') ? '.\perl'
-		       : ($^O eq 'MacOS') ? $^X
-		       : ($^O eq 'NetWare') ? 'perl'
-		       : './perl');
+	    my $cmd = which_perl();
 	    $cmd .= " -w $cmdfile 2>$errfile";
 	    if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
 	      # Use pipe instead of system so we don't inherit STD* from
@@ -604,3 +601,95 @@ sub linger {
     linger(\$watch);
     test { $watch eq '12' }
 }
+
+# bugid 10085
+# obj not freed early enough
+
+sub linger2 { 
+    my $obj = Watch->new($_[0], '2');
+    sub { sub { $obj } };
+}   
+{
+    my $watch = '1';
+    linger2(\$watch);
+    test { $watch eq '12' }
+}
+
+# bugid 16302 - named subs didn't capture lexicals on behalf of inner subs
+
+{
+    my $x = 1;
+    sub f16302 {
+	sub {
+	    test { defined $x and $x == 1 }
+	}->();
+    }
+}
+f16302();
+
+# The presence of an eval should turn cloneless anon subs into clonable
+# subs - otherwise the CvOUTSIDE of that sub may be wrong
+
+{
+    my %a;
+    for my $x (7,11) {
+	$a{$x} = sub { $x=$x; sub { eval '$x' } };
+    }
+    test { $a{7}->()->() + $a{11}->()->() == 18 };
+}
+
+{
+   # bugid #23265 - this used to coredump during destruction of PL_maincv
+   # and its children
+
+    my $progfile = "b23265.pl";
+    open(T, ">$progfile") or die "$0: $!\n";
+    print T << '__EOF__';
+        print
+            sub {$_[0]->(@_)} -> (
+                sub {
+                    $_[1]
+                        ?  $_[0]->($_[0], $_[1] - 1) .  sub {"x"}->()
+                        : "y"
+                },   
+                2
+            )
+            , "\n"
+        ;
+__EOF__
+    close T;
+    my $got = runperl(progfile => $progfile);
+    test { chomp $got; $got eq "yxx" };
+    END { 1 while unlink $progfile }
+}
+
+{
+    # bugid #24914 = used to coredump restoring PL_comppad in the
+    # savestack, due to the early freeing of the anon closure
+
+    my $got = runperl(stderr => 1, prog => 
+'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)'
+    );
+    test { $got eq "ok\n" };
+}
+
+# After newsub is redefined outside the BEGIN, it's CvOUTSIDE should point
+# to main rather than BEGIN, and BEGIN should be freed.
+
+{
+    my $flag = 0;
+    sub  X::DESTROY { $flag = 1 }
+    {
+	my $x;
+	BEGIN {$x = \&newsub }
+	sub newsub {};
+	$x = bless {}, 'X';
+    }
+    test { $flag == 1 };
+}
+
+
+
+
+
+