Spawning threads with open directory handles causes a crash #10387
Comments
From alexford@live.comCreated by alexford@live.comQuick summary: if you do an opendir() and then spawn threads, perl will crash. Perl Info |
From @tseeHi Alex, Alexander Ford wrote:
I only had a system perl 5.10.0 with a recent threads.pm from CPAN Best regards, |
|
The RT System itself - Status changed from 'new' to 'open' |
From @jdheddenSteffen, Alex, What version of threads are you using? perl -Mthreads -e 'print $threads::VERSION, "\n"' I tried your test with threads 1.77 on 5.8.8/9, 5.10.0/1, 5.12.0/1 and If you can upgrade to threads 1.77 and test again, it may be that this Thanks, On Tue, May 18, 2010 at 05:52, Steffen Mueller <smueller@cpan.org> wrote:
|
From @cpansproutThis is the result of this function in sv.c: DIR * Unfortunately, I don’t know how to duplicate a directory handle The attached patch (not to be applied; just an example) makes a copy I can see three ultimate solutions (in order of preference): a) Properly duplicate the dir handle so we have a new one with its own If b or c happens, I think this needs to be documented in threads.pm. |
From @cpansproutInline Patch--- blead/sv.c 2010-05-21 12:02:12.000000000 -0700
+++ blead-75154/sv.c 2010-05-23 15:47:28.000000000 -0700
@@ -10658,11 +10611,22 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, cons
DIR *
Perl_dirp_dup(pTHX_ DIR *const dp)
{
+ DIR *ret;
+
PERL_UNUSED_CONTEXT;
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 and remember what it is */
+ ret = PerlDir_open(".");
+ PerlLIO_dup2(my_dirfd(dp), my_dirfd(ret));
+ ptr_table_store(PL_ptr_table, dp, ret);
+ return ret;
}
/* duplicate a typeglob */ |
From @tseeHi Jerry, Jerry D. Hedden wrote:
It was threads 1.75. Installing threads 1.77 from CPAN into the ubuntu #0 0x00007ffff6ba04b5 in *__GI_raise (sig=<value optimized out>) at Sorry for the delayed reply! Cheers, |
From sinantrop@gmail.comThis is a bug report for perl from sinantrop@gmail.com, This program crashes perl on windows with those messages: sub ListDir local *DH; ListDir(".", sub fork; Flags: Site configuration information for perl 5.12.1: Configured by SYSTEM at Fri May 14 00:24:46 2010. Summary of my perl5 (revision 5 version 12 subversion 1) configuration: Locally applied patches: @INC for perl 5.12.1: Environment for perl 5.12.1: |
From @chornyOn Wed Sep 01 10:03:57 2010, strop wrote:
I'm not sure that it is a good idea to mix dirhandles and fork/threads. opendir(my $dh,$dir); ListDir(".", sub fork; It's result are meaningless though - for last file $proc will be -- |
|
The RT System itself - Status changed from 'new' to 'open' |
From @jdheddenOn Wed Sep 01 10:03:57 2010, strop wrote:
PATH=C:\WINDOWS\system32;C:\WINDOWS;C:\WINDOWS\System32\Wbem;c:\perl\bin
|
From @jdhedden(Oops. Sorry about the previous message. Hit the wrong button.) This bug report is really a duplicate of #75154 fork() under Windows uses threads. And the duplication of dir handles On Wed Sep 01 10:03:57 2010, strop wrote:
|
From @cpansproutOn Tue May 25 01:42:10 2010, sprout wrote:
Attached is a patch to fix this. On systems with fchdir, it dwims (a). |
From @cpansproutFrom: 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 Inline Patchdiff -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); |
From @jdheddenThis patch is written to rely on dirent->d_namlen which doesn't always Also, there's a build warning about 'len' possibly being On Sun, Sep 19, 2010 at 16:10, Father Chrysostomos via RT
|
From @cpansproutOn Tue Sep 21 10:59:20 2010, jdhedden wrote:
Why +1? d_namlen does not include the null. Does this new patch work for you? |
From @cpansproutFrom: 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 Inline Patchdiff -Nup blead/MANIFEST blead-75154-dirdup2/MANIFEST
--- blead/MANIFEST 2010-09-19 16:19:10.000000000 -0700
+++ blead-75154-dirdup2/MANIFEST 2010-09-21 11:16:37.000000000 -0700
@@ -4637,6 +4637,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 -Nup blead/sv.c blead-75154-dirdup2/sv.c
--- blead/sv.c 2010-09-16 07:47:14.000000000 -0700
+++ blead-75154-dirdup2/sv.c 2010-09-21 15:35:57.000000000 -0700
@@ -10730,11 +10730,101 @@ 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 = -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 -Nurp blead/t/op/threads-dirh.t blead-75154-dirdup2/t/op/threads-dirh.t
--- blead/t/op/threads-dirh.t 1969-12-31 16:00:00.000000000 -0800
+++ blead-75154-dirdup2/t/op/threads-dirh.t 2010-09-21 11:16:37.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); |
From @jdheddenOn Sun, Sep 26, 2010 at 19:42, Father Chrysostomos via RT
Yes, your new patch compiles and tests successfully. |
From @cpansproutOn Mon Sep 27 13:01:46 2010, jdhedden wrote:
Applied as 11a11e. |
|
@cpansprout - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#75154 (status was 'resolved')
Searchable as RT75154$
The text was updated successfully, but these errors were encountered: