Implement DIR* cloning on Windows

There doesn't seem to be a mechanism to clone FileFind handles on
Windows.  Therefore this implementation just reads all remaining
entries into a cache buffer and closes the handle.  All further
readdir() requests will be fulfilled from the cache buffer, in both
the original and the new interpreter.

This fixes bug 75154 on Windows (all tests in t/op/threads-dirh.t pass).

This commit also changes the return value of win32_telldir() to -1
for directory handles that have been read until the end.  The previous
return value was (NULL - dirp->start), which technically is not
valid C code.

API change alert: Perl_dirp_dup() gets an additional CLONE_PARAMS
parameter in this change (like all the other Perl_*_dup() functions).

7 files changed, 83 insertions, 18 deletions

diff --git a/embed.fnc b/embed.fnc
index 340d86d635..e08b76ac33 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1450,7 +1450,7 @@ ApR	|HEK*	|hek_dup	|NULLOK HEK* e|NN CLONE_PARAMS* param
 Ap	|void	|re_dup_guts	|NN const REGEXP *sstr|NN REGEXP *dstr \
 				|NN CLONE_PARAMS* param
 Ap	|PerlIO*|fp_dup		|NULLOK PerlIO *const fp|const char type|NN CLONE_PARAMS *const param
-ApR	|DIR*	|dirp_dup	|NULLOK DIR *const dp
+ApR	|DIR*	|dirp_dup	|NULLOK DIR *const dp|NN CLONE_PARAMS *const param
 ApR	|GP*	|gp_dup		|NULLOK GP *const gp|NN CLONE_PARAMS *const param
 ApR	|MAGIC*	|mg_dup		|NULLOK MAGIC *mg|NN CLONE_PARAMS *const param
 #if defined(PERL_IN_SV_C)
diff --git a/embed.h b/embed.h
index 5db82375f1..10eba36ab0 100644
--- a/embed.h
+++ b/embed.h
@@ -752,7 +752,7 @@
 #if defined(USE_ITHREADS)
 #define any_dup(a,b)		Perl_any_dup(aTHX_ a,b)
 #define cx_dup(a,b,c,d)		Perl_cx_dup(aTHX_ a,b,c,d)
-#define dirp_dup(a)		Perl_dirp_dup(aTHX_ a)
+#define dirp_dup(a,b)		Perl_dirp_dup(aTHX_ a,b)
 #define fp_dup(a,b,c)		Perl_fp_dup(aTHX_ a,b,c)
 #define gp_dup(a,b)		Perl_gp_dup(aTHX_ a,b)
 #define he_dup(a,b,c)		Perl_he_dup(aTHX_ a,b,c)
diff --git a/proto.h b/proto.h
index 644286b8b2..c7f40cb63e 100644
--- a/proto.h
+++ b/proto.h
@@ -7162,8 +7162,11 @@ PERL_CALLCONV PERL_CONTEXT*	Perl_cx_dup(pTHX_ PERL_CONTEXT* cx, I32 ix, I32 max,
 #define PERL_ARGS_ASSERT_CX_DUP	\
 	assert(param)
 
-PERL_CALLCONV DIR*	Perl_dirp_dup(pTHX_ DIR *const dp)
-			__attribute__warn_unused_result__;
+PERL_CALLCONV DIR*	Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
+			__attribute__warn_unused_result__
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_DIRP_DUP	\
+	assert(param)
 
 PERL_CALLCONV PerlIO*	Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
 			__attribute__nonnull__(pTHX_3);
diff --git a/sv.c b/sv.c
index 05e13e5285..88d022d3eb 100644
--- a/sv.c
+++ b/sv.c
@@ -11009,10 +11009,11 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
 /* duplicate a directory handle */
 
 DIR *
-Perl_dirp_dup(pTHX_ DIR *const dp)
+Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
 {
-#ifdef HAS_FCHDIR
     DIR *ret;
+
+#ifdef HAS_FCHDIR
     DIR *pwd;
     register const Direntry_t *dirent;
     char smallbuf[256];
@@ -11022,15 +11023,20 @@ Perl_dirp_dup(pTHX_ DIR *const dp)
 #endif
 
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_DIRP_DUP;
 
-#ifdef HAS_FCHDIR
     if (!dp)
 	return (DIR*)NULL;
+
     /* look for it in the table first */
     ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
     if (ret)
 	return ret;
 
+#ifdef HAS_FCHDIR
+
+    PERL_UNUSED_ARG(param);
+
     /* create anew */
 
     /* open the current directory (so we can switch back) */
@@ -11098,14 +11104,17 @@ Perl_dirp_dup(pTHX_ DIR *const dp)
 
     if (name && name != smallbuf)
 	Safefree(name);
+#endif
+
+#ifdef WIN32
+    ret = win32_dirp_dup(dp, param);
+#endif
 
     /* pop it in the pointer table */
-    ptr_table_store(PL_ptr_table, dp, ret);
+    if (ret)
+	ptr_table_store(PL_ptr_table, dp, ret);
 
     return ret;
-#else
-    return (DIR*)NULL;
-#endif
 }
 
 /* duplicate a typeglob */
@@ -11661,7 +11670,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 		    IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
 		    IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
 		    if (IoDIRP(dstr)) {
-			IoDIRP(dstr)	= dirp_dup(IoDIRP(dstr));
+			IoDIRP(dstr)	= dirp_dup(IoDIRP(dstr), param);
 		    } else {
 			NOOP;
 			/* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
diff --git a/t/op/threads-dirh.t b/t/op/threads-dirh.t
index 2e05f5d669..d207bc4835 100644
--- a/t/op/threads-dirh.t
+++ b/t/op/threads-dirh.t
@@ -45,8 +45,8 @@ SKIP: {
    skip $_[0], 5
  };
 
- if(!$Config::Config{d_fchdir}) {
-  $::TODO = 'dir handle cloning currently requires fchdir';
+ if(!$Config::Config{d_fchdir} && $^O ne "MSWin32") {
+  $::TODO = 'dir handle cloning currently requires fchdir on non-Windows platforms';
  }
 
  my @w :shared; # warnings accumulator
diff --git a/win32/win32.c b/win32/win32.c
index 2b6c3bdc52..3d1f46048e 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -981,10 +981,13 @@ win32_readdir(DIR *dirp)
 	    char buffer[MAX_PATH*2];
             char *ptr;
 
+            if (dirp->handle == INVALID_HANDLE_VALUE) {
+                res = 0;
+            }
 	    /* finding the next file that matches the wildcard
 	     * (which should be all of them in this directory!).
 	     */
-	    if (IsWin2000()) {
+	    else if (IsWin2000()) {
                 WIN32_FIND_DATAW wFindData;
 		res = FindNextFileW(dirp->handle, &wFindData);
 		if (res) {
@@ -1019,8 +1022,13 @@ win32_readdir(DIR *dirp)
 		dirp->end = dirp->start + newsize;
 		dirp->nfiles++;
 	    }
-	    else
+	    else {
 		dirp->curr = NULL;
+                if (dirp->handle != INVALID_HANDLE_VALUE) {
+                    FindClose(dirp->handle);
+                    dirp->handle = INVALID_HANDLE_VALUE;
+                }
+            }
 	}
 	return &(dirp->dirstr);
     }
@@ -1032,7 +1040,7 @@ win32_readdir(DIR *dirp)
 DllExport long
 win32_telldir(DIR *dirp)
 {
-    return (dirp->curr - dirp->start);
+    return dirp->curr ? (dirp->curr - dirp->start) : -1;
 }
 
 
@@ -1042,7 +1050,7 @@ win32_telldir(DIR *dirp)
 DllExport void
 win32_seekdir(DIR *dirp, long loc)
 {
-    dirp->curr = dirp->start + loc;
+    dirp->curr = loc == -1 ? NULL : dirp->start + loc;
 }
 
 /* Rewinddir resets the string pointer to the start */
@@ -1064,6 +1072,50 @@ win32_closedir(DIR *dirp)
     return 1;
 }
 
+/* duplicate a open DIR* for interpreter cloning */
+DllExport DIR *
+win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
+{
+    dVAR;
+    PerlInterpreter *const from = param->proto_perl;
+    PerlInterpreter *const to   = PERL_GET_THX;
+
+    long pos;
+    DIR *dup;
+
+    /* switch back to original interpreter because win32_readdir()
+     * might Renew(dirp->start).
+     */
+    if (from != to) {
+        PERL_SET_THX(from);
+    }
+
+    /* mark current position; read all remaining entries into the
+     * cache, and then restore to current position.
+     */
+    pos = win32_telldir(dirp);
+    while (win32_readdir(dirp)) {
+        /* read all entries into cache */
+    }
+    win32_seekdir(dirp, pos);
+
+    /* switch back to new interpreter to allocate new DIR structure */
+    if (from != to) {
+        PERL_SET_THX(to);
+    }
+
+    Newx(dup, 1, DIR);
+    memcpy(dup, dirp, sizeof(DIR));
+
+    Newx(dup->start, dirp->size, char);
+    memcpy(dup->start, dirp->start, dirp->size);
+
+    dup->end = dup->start + (dirp->end - dirp->start);
+    if (dirp->curr)
+        dup->curr = dup->start + (dirp->curr - dirp->start);
+
+    return dup;
+}
 
 /*
  * various stubs
diff --git a/win32/win32iop.h b/win32/win32iop.h
index 9c59037c53..45207900de 100644
--- a/win32/win32iop.h
+++ b/win32/win32iop.h
@@ -124,6 +124,7 @@ DllExport  long		win32_telldir(DIR *dirp);
 DllExport  void		win32_seekdir(DIR *dirp, long loc);
 DllExport  void		win32_rewinddir(DIR *dirp);
 DllExport  int		win32_closedir(DIR *dirp);
+DllExport  DIR*		win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param);
 
 DllExport  char*	win32_getenv(const char *name);
 DllExport  int		win32_putenv(const char *name);