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 */
--- /dev/null
+#!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);