[perl #75174] Clone dir handles

On systems that support fchdir, use it to clone dir handles.

On other systems, at least for now, don’t give the new thread a copy
of the handle. This is not ideal, but better than crashing.

1 files changed, 131 insertions, 0 deletions

diff --git a/t/op/threads-dirh.t b/t/op/threads-dirh.t
new file mode 100644
index 0000000000..2e05f5d669
--- /dev/null
+++ b/t/op/threads-dirh.t
@@ -0,0 +1,131 @@
+#!perl
+
+# Test interaction of threads and directory handles.
+
+BEGIN {
+     chdir 't' if -d 't';
+     @INC = '../lib';
+     require './test.pl';
+     $| = 1;
+
+     require Config;
+     if (!$Config::Config{useithreads}) {
+        print "1..0 # Skip: no ithreads\n";
+        exit 0;
+     }
+     if ($ENV{PERL_CORE_MINITEST}) {
+       print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
+       exit 0;
+     }
+
+     plan(6);
+}
+
+use strict;
+use warnings;
+use threads;
+use threads::shared;
+use File::Path;
+use File::Spec::Functions qw 'updir catdir';
+use Cwd 'getcwd';
+
+# Basic sanity check: make sure this does not crash
+fresh_perl_is <<'# this is no comment', 'ok', {}, 'crash when duping dirh';
+   use threads;
+   opendir dir, 'op';
+   async{}->join for 1..2;
+   print "ok";
+# this is no comment
+
+my $dir;
+SKIP: {
+ my $skip = sub {
+   chdir($dir);
+   chdir updir;
+   skip $_[0], 5
+ };
+
+ if(!$Config::Config{d_fchdir}) {
+  $::TODO = 'dir handle cloning currently requires fchdir';
+ }
+
+ my @w :shared; # warnings accumulator
+ local $SIG{__WARN__} = sub { push @w, $_[0] };
+
+ $dir = catdir getcwd(), "thrext$$" . int rand() * 100000;
+
+ rmtree($dir);
+ mkdir($dir);
+
+ # Create a dir structure like this:
+ #   $dir
+ #     |
+ #     `- toberead
+ #            |
+ #            +---- thrit
+ #            |
+ #            +---- rile
+ #            |
+ #            `---- zor
+
+ chdir($dir);
+ mkdir 'toberead';
+ chdir 'toberead';
+ {open my $fh, ">thrit" or &$skip("Cannot create file thrit")}
+ {open my $fh, ">rile" or &$skip("Cannot create file rile")}
+ {open my $fh, ">zor" or &$skip("Cannot create file zor")}
+ chdir updir;
+
+ # Then test that dir iterators are cloned correctly.
+
+ opendir my $toberead, 'toberead';
+ my $start_pos = telldir $toberead;
+ my @first_2 = (scalar readdir $toberead, scalar readdir $toberead);
+ my @from_thread = @{; async { [readdir $toberead ] } ->join };
+ my @from_main = readdir $toberead;
+ is join('-', sort @from_thread), join('-', sort @from_main),
+     'dir iterator is copied from one thread to another';
+ like
+   join('-', "", sort(@first_2, @from_thread), ""),
+   qr/(?<!-rile)-rile-thrit-zor-(?!zor-)/i,
+  'cloned iterator iterates exactly once over everything not already seen';
+
+ seekdir $toberead, $start_pos;
+ readdir $toberead for 1 .. @first_2+@from_thread;
+ is
+   async { readdir $toberead // 'undef' } ->join, 'undef',
+  'cloned dir iterator that points to the end of the directory'
+ ;
+
+ # Make sure the cloning code can handle file names longer than 255 chars
+ SKIP: {
+  chdir 'toberead';
+  open my $fh,
+    ">floccipaucinihilopilification-"
+   . "pneumonoultramicroscopicsilicovolcanoconiosis-"
+   . "lopadotemachoselachogaleokranioleipsanodrimypotrimmatosilphiokarabo"
+   . "melitokatakechymenokichlepikossyphophattoperisteralektryonoptokephal"
+   . "liokinklopeleiolagoiosiraibaphetraganopterygon"
+    or
+     chdir updir,
+     skip("OS does not support long file names (and I mean *long*)", 1);
+  chdir updir;
+  opendir my $dirh, "toberead";
+  my $test_name
+    = "dir iterators can be cloned when the next fn > 255 chars";
+  while() {
+   my $pos = telldir $dirh;
+   my $fn = readdir($dirh);
+   if(!defined $fn) { fail($test_name); last SKIP; }
+   if($fn =~ 'lagoio') { 
+    seekdir $dirh, $pos;
+    last;
+   }
+  }
+  is length async { scalar readdir $dirh } ->join, 257, $test_name;
+ }
+
+ is scalar @w, 0, 'no warnings during all that' or diag @w;
+ chdir updir;
+}
+rmtree($dir);