From @cpansprout

From: Father Chrysostomos <sprout@cpan.org>

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

Inline Patch

diff -up blead/MANIFEST blead-75154-dirdup/MANIFEST
--- blead/MANIFEST	2010-09-11 14:19:12.000000000 -0700
+++ blead-75154-dirdup/MANIFEST	2010-09-17 12:49:00.000000000 -0700
@@ -4635,6 +4635,7 @@ t/op/symbolcache.t		See if undef/delete 
 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 -up blead/sv.c blead-75154-dirdup/sv.c
--- blead/sv.c	2010-09-09 12:00:10.000000000 -0700
+++ blead-75154-dirdup/sv.c	2010-09-18 06:21:19.000000000 -0700
@@ -10849,11 +10849,95 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, cons
 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;
+    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);
+
+    /* 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 = dirent->d_namlen;
+	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 == dirent->d_namlen
+		 && 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;
+	    }
+	}
+    }
+
+    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 -up blead/dist/threads/lib/threads.pm blead-75154-dirdup/dist/threads/lib/threads.pm
--- blead/dist/threads/lib/threads.pm	2010-07-07 07:22:10.000000000 -0700
+++ blead-75154-dirdup/dist/threads/lib/threads.pm	2010-09-17 01:12:59.000000000 -0700
@@ -1005,6 +1005,16 @@ mutexes that are needed to control funct
 For this reason, the use of C<END> blocks in threads is B<strongly>
 discouraged.
 
+=item Directory handles
+
+In perl 5.14.0 and higher, if your system does not support the C<fchdir> C
+function, directory handles will not be copied to new threads. You can use
+the C<d_fchdir> variable in L<Config.pm|Config> to determine whether your
+system supports it.
+
+In prior perl versions, leaving directory handles open when threads were
+created could result in crashes or memory corruption.
+
 =item Perl Bugs and the CPAN Version of L<threads>
 
 Support for threads extends beyond the code in this module (i.e.,
diff -rNup blead/t/op/threads-dirh.t blead-75154-dirdup/t/op/threads-dirh.t
--- blead/t/op/threads-dirh.t	1969-12-31 16:00:00.000000000 -0800
+++ blead-75154-dirdup/t/op/threads-dirh.t	2010-09-18 06:17:53.000000000 -0700
@@ -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);

Spawning threads with open directory handles causes a crash #10387

Description

Metadata

Metadata

Assignees

Labels

Type

Projects

Milestone

Relationships

Development

Issue actions