Add sanity checks for far, far distant dates.

[p5sagit/p5-mst-13.2.git] / t / op / closure.t

diff --git a/t/op/closure.t b/t/op/closure.t
old mode 100755 (executable)
new mode 100644 (file)
index f9da311..5e3bf45
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -12,8 +12,9 @@ BEGIN {
 }
 
 use Config;
+require './test.pl'; # for runperl()
 
-print "1..186\n";
+print "1..188\n";
 
 my $test = 1;
 sub test (&) {
@@ -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;
@@ -462,15 +463,10 @@ END
            }
          } else {
            # No fork().  Do it the hard way.
-           my $cmdfile = "tcmd$$";  $cmdfile++ while -e $cmdfile;
-           my $errfile = "terr$$";  $errfile++ while -e $errfile;
-           my @tmpfiles = ($cmdfile, $errfile);
+           my $cmdfile = tempfile();
+           my $errfile = tempfile();
            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
@@ -480,18 +476,15 @@ END
              { local $/; $output = join '', <PERL> }
              close PERL;
            } else {
-             my $outfile = "tout$$";  $outfile++ while -e $outfile;
-             push @tmpfiles, $outfile;
+             my $outfile = tempfile();
              system "$cmd >$outfile";
              { local $/; open IN, $outfile; $output = <IN>; close IN }
            }
            if ($?) {
              printf "not ok: exited with error code %04X\n", $?;
-             $debugging or do { 1 while unlink @tmpfiles };
              exit;
            }
            { local $/; open IN, $errfile; $errors = <IN>; close IN }
-           1 while unlink @tmpfiles;
          }
          print $output;
          print STDERR $errors;
@@ -641,8 +634,6 @@ f16302();
     test { $a{7}->()->() + $a{11}->()->() == 18 };
 }
 
-require './test.pl'; # for runperl()
-
 {
    # bugid #23265 - this used to coredump during destruction of PL_maincv
    # and its children
@@ -673,9 +664,41 @@ __EOF__
     # 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 qw(ok)'
+'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)'
     );
-    test { $got eq 'ok' };
+    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 };
+}
+
+# don't copy a stale lexical; crate a fresh undef one instead
+
+sub f {
+    my $x if $_[0];
+    sub { \$x }
+}
+
+{
+    f(1);
+    my $c1= f(0);
+    my $c2= f(0);
+
+    my $r1 = $c1->();
+    my $r2 = $c2->();
+    test { $r1 != $r2 };
 }