Avoid race conditions with files in /tmp, by explicitly checking dev & inode.

(Concerns raised by and the form of the solution suggested by Bram.)

1 files changed, 19 insertions, 15 deletions

diff --git a/t/io/perlio.t b/t/io/perlio.t
index 3a81512c82..d95e3963e2 100644
--- a/t/io/perlio.t
+++ b/t/io/perlio.t
@@ -101,30 +101,34 @@ ok(close($utffh));
       # hardcoded default temp path
       my $perlio_tmp_file_glob = '/tmp/PerlIO_??????';
 
-      my @before = glob $perlio_tmp_file_glob;
-
       ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir');
 
-      my @after = glob $perlio_tmp_file_glob;
-      is( "@after", "@before", "No tmp files leaked");
-
-      unlink_new(\@before, \@after);
+      my $filename = find_filename($x, $perlio_tmp_file_glob);
+      is($filename, undef, "No tmp files leaked");
+      unlink $filename if defined $filename;
 
       mkdir $ENV{TMPDIR};
       ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir');
 
-      @after = glob $perlio_tmp_file_glob;
-      is( "@after", "@before", "No tmp files leaked");
-
-      unlink_new(\@before, \@after);
+      $filename = find_filename($x, $perlio_tmp_file_glob);
+      is($filename, undef, "No tmp files leaked");
+      unlink $filename if defined $filename;
     }
 }
 
-sub unlink_new {
-    my ($before, $after) = @_;
-    my %before;
-    @before{@$before} = ();
-    unlink grep {!exists $before{$_}} @$after;
+sub find_filename {
+    my ($fh, @globs) = @_;
+    my ($dev, $inode) = stat $fh;
+    die "Can't stat $fh: $!" unless defined $dev;
+
+    foreach (@globs) {
+	foreach my $file (glob $_) {
+	    my ($this_dev, $this_inode) = stat $file;
+	    next unless defined $this_dev;
+	    return $file if $this_dev == $dev && $this_inode == $inode;
+	}
+    }
+    return;
 }
 
 # in-memory open