Front page | perl.perl5.porters |
Postings from September 2010
Re: [perl #75154] Spawning threads with open directory handles causesa crash
Thread Previous
From:
Jerry D. Hedden
Date:
September 21, 2010 10:58
Subject:
Re: [perl #75154] Spawning threads with open directory handles causesa crash
Message ID:
AANLkTikE6F+NMUKyNno8Mdh5cRFv7J+sv02nh0VYuX7O@mail.gmail.com
This patch is written to rely on dirent->d_namlen which doesn't always
exist. (I tried it on Cygwin and got build failures). I tried
replacing occurrences of "dirent->d_namlen" with
"strlen(dirent->d_name)+1", and it built and tested successfully.
Also, there's a build warning about 'len' possibly being
uninitialized, so initializing it to something like -1 should work.
On Sun, Sep 19, 2010 at 16:10, Father Chrysostomos via RT
<perlbug-followup@perl.org> wrote:
> On Tue May 25 01:42:10 2010, sprout wrote:
>> This is the result of this function in sv.c:
>>
>> DIR *
>> Perl_dirp_dup(pTHX_ DIR *const dp)
>> {
>> PERL_UNUSED_CONTEXT;
>> if (!dp)
>> return (DIR*)NULL;
>> /* XXX TODO */
>> return dp;
>> }
>>
>> Unfortunately, I don’t know how to duplicate a directory handle
>> properly.
>>
>> The attached patch (not to be applied; just an example) makes a copy
>> using dup2, but the resulting dir handles share the same iterator
>> (i.e., the current behaviour, but without the crash). The code works
>> on Mac OS X, but I doubt it’s portable. I don’t know how to make it
>> work on other systems.
>>
>> 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
>> iterator (I can’t find a fopendir function anywhere)
>> b) Simple duplicate the dir handle as in my example
>> c) Don’t copy dir handles into threads (return (DIR*)NULL; I tried
>> that and it works)
>>
>> If b or c happens, I think this needs to be documented in threads.pm.
>> We may have to choose between different items in the list at configure-
>> time, based on OS.
>>
>
> Attached is a patch to fix this. On systems with fchdir, it dwims (a).
> On other systems the dir handle is simply not passed to the thread (c).
>
>
> 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.
>
> 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);
>
>
Thread Previous