From @jkeenan

0001-Conduct-tests-of-IO-Dir-in-temporary-directory.patch

From 233dd1df114316ec88a5d6e52c4410aef99c88bd Mon Sep 17 00:00:00 2001
From: James E Keenan <jkeenan@cpan.org>
Date: Fri, 28 Dec 2018 23:05:19 -0500
Subject: [PATCH] Conduct tests of IO::Dir in temporary directory

For RT # 133740:  After the release of perl-5.29.5, smoke tests
intermittently began to report failures in dist/IO/t/io_dir.t.

In preceding  months, similar intermittent failures had been reported
for files testing File::Find (RT 133658) and GDBM_File (RT 133664).  In
those cases the problem was diagnosed as race conditions under parallel
testing where test files and directories were being created in or
underneath the current working directory without resort to tempdirs or
tempfiles.

The testing in dist/IO/t/io_dir.t presumes the existence of a stable set
of files and subdirectories in dist/IO/.  If additional files or
subdirectories are created while this file is being run, that
presumption is no longer met.

The dist/IO/t/ directory was therefore inspected for test files which,
for testing purposes, would create files or directories underneath the
dist/IO/.  The following test files do so:

    io_file.t
    io_linenum.t
    io_taint.t
    io_tell.t
    io_unix.t
    io_utf8argv.t
    io_utf8.t
    io_xs.t

Of the above, only io_xs.t takes the precaution of using
IO::File->new_tmpfile().

Using File::Temp::tempdir in this file should mitigate the problem.

In addition, all tests in io_dir.t now have descriptions.
---
 dist/IO/t/io_dir.t | 100 ++++++++++++++++++++++++++++-----------------
 1 file changed, 62 insertions(+), 38 deletions(-)

diff --git a/dist/IO/t/io_dir.t b/dist/IO/t/io_dir.t
index 762c452ec8..ba400dee97 100644
--- a/dist/IO/t/io_dir.t
+++ b/dist/IO/t/io_dir.t
@@ -9,57 +9,81 @@ BEGIN {
 }
 
 use strict;
+use File::Temp qw( tempdir );
+use Cwd;
 
-my $DIR = $^O eq 'MacOS' ? ":" : ".";
+my $cwd = cwd();
 
-my $CLASS = "IO::Dir";
-my $dot = $CLASS->new($DIR);
-ok(defined($dot));
+{
+    my $DIR = tempdir( CLEANUP => 1 );
+    chdir $DIR or die "Unable to chdir to $DIR";
+    my @IO_files =
+        ( 'ChangeLog', 'IO.pm', 'IO.xs', 'Makefile.PL', 'poll.c', 'poll.h', 'README' );
+    my @IO_subdirs = ( qw| hints  lib  t | );
 
-my @a = sort <*>;
-my $first;
-do { $first = $dot->read } while defined($first) && $first =~ /^\./;
-ok(+(grep { $_ eq $first } @a));
+    for my $f (@IO_files) {
+        open my $OUT, '>', $f or die "Unable to open '$DIR/$f' for writing";
+        close $OUT or die "Unable to close '$DIR/$f' after writing";
+    }
+    for my $d (@IO_subdirs) { mkdir $d or die "Unable to mkdir '$DIR/$d'"; }
 
-my @b = sort($first, (grep {/^[^.]/} $dot->read));
-ok(+(join("\0", @a) eq join("\0", @b)));
+    my $CLASS = "IO::Dir";
+    my $dot = $CLASS->new($DIR);
+    ok(defined($dot), "Able to create IO::Dir object for $DIR");
 
-ok($dot->rewind,'rewind');
-my @c = sort grep {/^[^.]/} $dot->read;
-ok(+(join("\0", @b) eq join("\0", @c)));
+    my @a = sort <*>;
+    my $first;
+    do { $first = $dot->read } while defined($first) && $first =~ /^\./;
+    ok(+(grep { $_ eq $first } @a), "directory entry found");
 
-ok($dot->close,'close');
-{ local $^W; # avoid warnings on invalid dirhandle
-ok(!$dot->rewind, "rewind on closed");
-ok(!defined($dot->read));
-}
+    my @b = sort($first, (grep {/^[^.]/} $dot->read));
+    ok(+(join("\0", @a) eq join("\0", @b)), "two lists of directory entries match (Case 1)");
+
+    ok($dot->rewind,'rewind');
+    my @c = sort grep {/^[^.]/} $dot->read;
+    ok(+(join("\0", @b) eq join("\0", @c)), "two lists of directory entries match (Case 2)");
+
+    ok($dot->close,'close');
+    {
+        local $^W; # avoid warnings on invalid dirhandle
+        ok(!$dot->rewind, "rewind on closed");
+        ok(!defined($dot->read), "Directory handle closed; hence 'read' returns undef");
+    }
 
-open(FH,'>','X') || die "Can't create x";
-print FH "X";
-close(FH) or die "Can't close: $!";
+    open(FH,'>','X') || die "Can't create x";
+    print FH "X";
+    close(FH) or die "Can't close: $!";
 
-my %dir;
-tie %dir, $CLASS, $DIR;
-my @files = keys %dir;
+    my %dir;
+    tie %dir, $CLASS, $DIR;
+    my @files = keys %dir;
 
-# I hope we do not have an empty dir :-)
-ok(scalar @files);
+    # I hope we do not have an empty dir :-)
+    ok(scalar @files, "Tied hash interface finds directory entries");
 
-my $stat = $dir{'X'};
-isa_ok($stat,'File::stat');
-ok(defined($stat) && $stat->size == 1);
+    my $stat = $dir{'X'};
+    isa_ok($stat,'File::stat');
+    ok(defined($stat) && $stat->size == 1,
+        "Confirm that we wrote a file of size 1 byte");
 
-delete $dir{'X'};
+    delete $dir{'X'};
 
-ok(-f 'X');
+    ok(-f 'X', "Confirm that file still exists after entry in tied hash has been deleted");
 
-my %dirx;
-tie %dirx, $CLASS, $DIR, DIR_UNLINK;
+    my %dirx;
+    tie %dirx, $CLASS, $DIR, DIR_UNLINK;
 
-my $statx = $dirx{'X'};
-isa_ok($statx,'File::stat');
-ok(defined($statx) && $statx->size == 1);
+    my $statx = $dirx{'X'};
+    isa_ok($statx,'File::stat');
+    ok(defined($statx) && $statx->size == 1,
+        "Confirm that we still have the 1-byte file");
 
-delete $dirx{'X'};
+    delete $dirx{'X'};
+
+    my $description = "Tied hash interface with DIR_UNLINK:";
+    $description .= "  deleting an element from hash deletes corresponding directory entry";
+    ok(!(-f 'X'), $description);
+
+    chdir $cwd or die "Unable to chdir back to $cwd";
+}
 
-ok(!(-f 'X'));
-- 
2.17.1

dist/IO/t/io_dir.t: intermittent failures #16795

Description

Metadata

Metadata

Assignees

Labels

Type

Projects

Milestone

Relationships

Development

Issue actions