[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.

diff --git a/MANIFEST b/MANIFEST
index 172b7c3..3cf53aa 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4653,6 +4653,7 @@ t/op/symbolcache.t                See if undef/delete works on stashes with functions
 t/op/sysio.t                   See if sysread and syswrite work
 t/op/taint.t                   See if tainting works
 t/op/threads_create.pl         Ancillary file for t/op/threads.t
+t/op/threads-dirh.t            Test interaction of threads and dir handles
 t/op/threads.t                 Misc. tests for perl features with threads
 t/op/tiearray.t                        See if tie for arrays works
 t/op/tie_fetch_count.t         See if FETCH is only called once on tied variables

diff --git a/sv.c b/sv.c
index fb30ff3..351df2d 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -10838,11 +10838,101 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
 DIR *
 Perl_dirp_dup(pTHX_ DIR *const dp)
 {
+#ifdef HAS_FCHDIR
+    DIR *ret;
+    DIR *pwd;
+    register const Direntry_t *dirent;
+    char smallbuf[256];
+    char *name = NULL;
+    STRLEN len = -1;
+    long pos;
+#endif
+
     PERL_UNUSED_CONTEXT;
+
+#ifdef HAS_FCHDIR
     if (!dp)
        return (DIR*)NULL;
-    /* XXX TODO */
-    return dp;
+    /* look for it in the table first */
+    ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
+    if (ret)
+       return ret;
+
+    /* create anew */
+
+    /* open the current directory (so we can switch back) */
+    if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
+
+    /* chdir to our dir handle and open the present working directory */
+    if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
+       PerlDir_close(pwd);
+       return (DIR *)NULL;
+    }
+    /* Now we should have two dir handles pointing to the same dir. */
+
+    /* Be nice to the calling code and chdir back to where we were. */
+    fchdir(my_dirfd(pwd)); /* If this fails, then what? */
+
+    /* We have no need of the pwd handle any more. */
+    PerlDir_close(pwd);
+
+#ifdef DIRNAMLEN
+# define d_namlen(d) (d)->d_namlen
+#else
+# define d_namlen(d) strlen((d)->d_name)
+#endif
+    /* Iterate once through dp, to get the file name at the current posi-
+       tion. Then step back. */
+    pos = PerlDir_tell(dp);
+    if ((dirent = PerlDir_read(dp))) {
+       len = d_namlen(dirent);
+       if (len <= sizeof smallbuf) name = smallbuf;
+       else Newx(name, len, char);
+       Move(dirent->d_name, name, len, char);
+    }
+    PerlDir_seek(dp, pos);
+
+    /* Iterate through the new dir handle, till we find a file with the
+       right name. */
+    if (!dirent) /* just before the end */
+       for(;;) {
+           pos = PerlDir_tell(ret);
+           if (PerlDir_read(ret)) continue; /* not there yet */
+           PerlDir_seek(ret, pos); /* step back */
+           break;
+       }
+    else {
+       const long pos0 = PerlDir_tell(ret);
+       for(;;) {
+           pos = PerlDir_tell(ret);
+           if ((dirent = PerlDir_read(ret))) {
+               if (len == d_namlen(dirent)
+                && memEQ(name, dirent->d_name, len)) {
+                   /* found it */
+                   PerlDir_seek(ret, pos); /* step back */
+                   break;
+               }
+               /* else we are not there yet; keep iterating */
+           }
+           else { /* This is not meant to happen. The best we can do is
+                     reset the iterator to the beginning. */
+               PerlDir_seek(ret, pos0);
+               break;
+           }
+       }
+    }
+#undef d_namlen
+
+    if (name && name != smallbuf)
+       Safefree(name);
+
+    /* pop it in the pointer table */
+    ptr_table_store(PL_ptr_table, dp, ret);
+
+    return ret;
+#else
+    return (DIR*)NULL;
+#endif
 }
 
 /* duplicate a typeglob */

diff --git a/t/op/threads-dirh.t b/t/op/threads-dirh.t
new file mode 100644 (file)
index 0000000..2e05f5d
--- /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);