win32: inject a socket-aware version of CloseHandle() into the CRT

_close() on an fd calls CloseHandle(), which is illegal if the fd
contains a socket handle.

We previously worked around this by having our own close(), which called
closesocket() before calling _close()
(e601c439adce167078ac7b49550c0418ace86f94).

Amusingly, the author of that solution thought it's just a temporary
workaround:

  /*
   * close RTL fd while respecting sockets
   * added as temporary measure until PerlIO has real
   * Win32 native layer
   *   -- BKS, 11-11-2000
   */

To make it thread-safe, we had to manipulate the internals of file
descriptors, which kept changing
(b47a847f6284f6f98ad7509cf77a4aeb802d8fce).

Unfortunately, the C runtime has been rewritten and it no longer exposes
them at all. We had to disable the thread-safety fix in Visual C++ 2015
builds (1f664ef5314fb6e438137c44c95cf5ecdbdb5e9b). It also wouldn't work
with MinGW configured to use UCRT.

This commit introduces a new solution: we inject a socket-aware version
of CloseHandle() into the C runtime library. Hopefully, this will be
less fragile.

This also fixes a few issues that the original solution didn't:

  - Closing a busy pipe doesn't cause a deadlock (fixes #19963)

  - _dup2 properly closes an overwritten socket (fixes #20920)

4 files changed, 182 insertions, 173 deletions

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 4183474c53..1953ca6e55 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -365,9 +365,19 @@ L</Modules and Pragmata> section.
 
 =over 4
 
-=item XXX-some-platform
+=item Windows
 
-XXX
+=over 4
+
+=item *
+
+C<POSIX::dup2> no longer creates broken sockets. [GH #20920]
+
+=item *
+
+Closing a busy pipe could cause Perl to hang. [GH #19963]
+
+=back
 
 =back
 
diff --git a/win32/win32.c b/win32/win32.c
index 435d160eda..bc0cf0f742 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -38,6 +38,7 @@
 #include <io.h>
 #include <signal.h>
 #include <winioctl.h>
+#include <winternl.h>
 
 /* #include "config.h" */
 
@@ -156,9 +157,6 @@ static void translate_to_errno(void);
 START_EXTERN_C
 HANDLE	w32_perldll_handle = INVALID_HANDLE_VALUE;
 char	w32_module_name[MAX_PATH+1];
-#ifdef WIN32_DYN_IOINFO_SIZE
-Size_t	w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */
-#endif
 END_EXTERN_C
 
 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
@@ -3313,7 +3311,7 @@ win32_freopen(const char *path, const char *mode, FILE *stream)
 DllExport int
 win32_fclose(FILE *pf)
 {
-    return my_fclose(pf);	/* defined in win32sck.c */
+    return fclose(pf);
 }
 
 DllExport int
@@ -3913,13 +3911,10 @@ win32_open(const char *path, int flag, ...)
     return open(PerlDir_mapA(path), flag, pmode);
 }
 
-/* close() that understands socket */
-extern int my_close(int);	/* in win32sck.c */
-
 DllExport int
 win32_close(int fd)
 {
-    return my_close(fd);
+    return _close(fd);
 }
 
 DllExport int
@@ -5172,6 +5167,172 @@ ansify_path(void)
     win32_free(wide_path);
 }
 
+/* This hooks a function that is imported by the specified module. The hook is
+ * local to that module. */
+static bool
+win32_hook_imported_function_in_module(
+    HMODULE module, LPCSTR fun_name, FARPROC hook_ptr
+)
+{
+    ULONG_PTR image_base = (ULONG_PTR)module;
+    PIMAGE_DOS_HEADER dos_header = (PIMAGE_DOS_HEADER)image_base;
+    PIMAGE_NT_HEADERS nt_headers
+        = (PIMAGE_NT_HEADERS)(image_base + dos_header->e_lfanew);
+    PIMAGE_OPTIONAL_HEADER opt_header = &nt_headers->OptionalHeader;
+
+    PIMAGE_DATA_DIRECTORY data_dir = opt_header->DataDirectory;
+    DWORD data_dir_len = opt_header->NumberOfRvaAndSizes;
+
+    BOOL is_idt_present = data_dir_len > IMAGE_DIRECTORY_ENTRY_IMPORT
+        && data_dir[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress != 0;
+
+    if (!is_idt_present)
+        return FALSE;
+
+    BOOL found = FALSE;
+
+    /* Import Directory Table */
+    PIMAGE_IMPORT_DESCRIPTOR idt = (PIMAGE_IMPORT_DESCRIPTOR)(
+        image_base + data_dir[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress
+    );
+
+    for (; idt->Name != 0; ++idt) {
+        /* Import Lookup Table */
+        PIMAGE_THUNK_DATA ilt
+            = (PIMAGE_THUNK_DATA)(image_base + idt->OriginalFirstThunk);
+        /* Import Address Table */
+        PIMAGE_THUNK_DATA iat
+            = (PIMAGE_THUNK_DATA)(image_base + idt->FirstThunk);
+
+        ULONG_PTR address_of_data;
+        for (; address_of_data = ilt->u1.AddressOfData; ++ilt, ++iat) {
+            /* Ordinal imports are quite rare, so skipping them will most likely
+             * not cause any problems. */
+            BOOL is_ordinal
+                = address_of_data >> ((sizeof(address_of_data) * 8) - 1);
+
+            if (is_ordinal)
+                continue;
+
+            LPCSTR name = (
+                (PIMAGE_IMPORT_BY_NAME)(image_base + address_of_data)
+            )->Name;
+
+            if (strEQ(name, fun_name)) {
+                DWORD old_protect = 0;
+                BOOL succ = VirtualProtect(
+                    &iat->u1.Function, sizeof(iat->u1.Function), PAGE_READWRITE,
+                    &old_protect
+                );
+                if (!succ)
+                    return FALSE;
+
+                iat->u1.Function = (ULONG_PTR)hook_ptr;
+                found = TRUE;
+
+                VirtualProtect(
+                    &iat->u1.Function, sizeof(iat->u1.Function), old_protect,
+                    &old_protect
+                );
+                break;
+            }
+        }
+    }
+
+    return found;
+}
+
+typedef NTSTATUS (NTAPI *pNtQueryInformationFile_t)(HANDLE, PIO_STATUS_BLOCK, PVOID, ULONG, ULONG);
+pNtQueryInformationFile_t pNtQueryInformationFile = NULL;
+
+typedef BOOL (WINAPI *pCloseHandle)(HANDLE h);
+static pCloseHandle CloseHandle_orig;
+
+/* CloseHandle() that supports sockets. CRT uses mutexes during file operations,
+ * so the lack of thread safety in this function isn't a problem. */
+static BOOL WINAPI
+my_CloseHandle(HANDLE h)
+{
+    /* In theory, passing a non-socket handle to closesocket() is fine. It
+     * should return a WSAENOTSOCK error, which is easy to recover from.
+     * However, we should avoid doing that because it's not that simple in
+     * practice. For instance, it can deadlock on a handle to a stuck pipe (see:
+     * https://github.com/Perl/perl5/issues/19963).
+     *
+     * There's no foolproof way to tell if a handle is a socket (mostly because
+     * of the non-IFS sockets), but in some cases we can tell if a handle
+     * is definitely *not* a socket.
+     */
+
+    /* GetFileType() always returns FILE_TYPE_PIPE for sockets. */
+    BOOL maybe_socket = (GetFileType(h) == FILE_TYPE_PIPE);
+
+    if (maybe_socket && pNtQueryInformationFile) {
+        IO_STATUS_BLOCK isb;
+        struct {
+            ULONG name_len;
+            WCHAR name[100];
+        } volume = {0};
+
+        /* There are many ways to tell a named pipe from a socket, but almost
+         * all of them can deadlock on a handle to a stuck pipe (like in the
+         * bug ticket mentioned above). According to my tests,
+         * FileVolumeNameInfomation is the only relevant function that doesn't
+         * suffer from this problem.
+         *
+         * It's undocumented and it requires Windows 10, so on older systems
+         * we always pass pipes to closesocket().
+         */
+        NTSTATUS s = pNtQueryInformationFile(
+            h, &isb, &volume, sizeof(volume), 58 /* FileVolumeNameInformation */
+        );
+        if (NT_SUCCESS(s)) {
+            maybe_socket = (_wcsnicmp(
+                volume.name, L"\\Device\\NamedPipe", C_ARRAY_LENGTH(volume.name)
+            ) != 0);
+        }
+    }
+
+    if (maybe_socket)
+        if (closesocket((SOCKET)h) == 0)
+            return TRUE;
+        else if (WSAGetLastError() != WSAENOTSOCK)
+            return FALSE;
+
+    return CloseHandle_orig(h);
+}
+
+/* Hook CloseHandle() inside CRT so its functions like _close() or
+ * _dup2() can close sockets properly. */
+static void
+win32_hook_closehandle_in_crt()
+{
+    /* Get the handle to the CRT module basing on the address of _close()
+     * function. */
+    HMODULE crt_handle;
+    BOOL succ = GetModuleHandleExA(
+        GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
+        | GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, (LPCSTR)_close,
+        &crt_handle
+    );
+    if (!succ)
+        return;
+
+    CloseHandle_orig = (pCloseHandle)GetProcAddress(
+        GetModuleHandleA("kernel32.dll"), "CloseHandle"
+    );
+    if (!CloseHandle_orig)
+        return;
+
+    win32_hook_imported_function_in_module(
+        crt_handle, "CloseHandle", (FARPROC)my_CloseHandle
+    );
+
+    pNtQueryInformationFile = (pNtQueryInformationFile_t)GetProcAddress(
+        GetModuleHandleA("ntdll.dll"), "NtQueryInformationFile"
+    );
+}
+
 void
 Perl_win32_init(int *argcp, char ***argvp)
 {
@@ -5208,17 +5369,7 @@ Perl_win32_init(int *argcp, char ***argvp)
     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
     GetVersionEx(&g_osver);
 
-#ifdef WIN32_DYN_IOINFO_SIZE
-    {
-        Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
-        if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
-            fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
-            exit(1);
-        }
-        ioinfo_size /= IOINFO_ARRAY_ELTS;
-        w32_ioinfo_size = ioinfo_size;
-    }
-#endif
+    win32_hook_closehandle_in_crt();
 
     ansify_path();
 
diff --git a/win32/win32.h b/win32/win32.h
index c184b9f5f5..77e4f06279 100644
--- a/win32/win32.h
+++ b/win32/win32.h
@@ -426,7 +426,6 @@ DllExport void		win32_get_child_IO(child_IO_table* ptr);
 DllExport HWND		win32_create_message_window(void);
 DllExport int		win32_async_check(pTHX);
 
-extern int		my_fclose(FILE *);
 extern char *		win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len);
 extern char *		win32_get_sitelib(const char *pl, STRLEN *const len);
 extern char *		win32_get_vendorlib(const char *pl, STRLEN *const len);
@@ -566,83 +565,6 @@ void win32_wait_for_children(pTHX);
 #  define PERL_WAIT_FOR_CHILDREN win32_wait_for_children(aTHX)
 #endif
 
-/* The following ioinfo struct manipulations had been removed but were
- * reinstated to fix RT#120091/118059. However, they do not work with
- * the rewritten CRT in VS2015 so they are removed once again for VS2015
- * onwards, which will therefore suffer from the reintroduction of the
- * close socket bug. */
-#if (!defined(_MSC_VER)) || (defined(_MSC_VER) && _MSC_VER < 1900)
-
-#ifdef PERL_CORE
-
-/* C doesn't like repeat struct definitions */
-#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION>=3)
-#  undef _CRTIMP
-#endif
-#ifndef _CRTIMP
-#  define _CRTIMP __declspec(dllimport)
-#endif
-
-#ifndef __MINGW32__
-/* size of ioinfo struct is determined at runtime */
-#  define WIN32_DYN_IOINFO_SIZE
-#endif
-
-#ifndef WIN32_DYN_IOINFO_SIZE
-/*
- * Control structure for lowio file handles
- */
-typedef struct {
-    intptr_t osfhnd;/* underlying OS file HANDLE */
-    char osfile;    /* attributes of file (e.g., open in text mode?) */
-    char pipech;    /* one char buffer for handles opened on pipes */
-    int lockinitflag;
-    CRITICAL_SECTION lock;
-} ioinfo;
-#else
-typedef intptr_t ioinfo;
-#endif
-
-/*
- * Array of arrays of control structures for lowio files.
- */
-EXTERN_C _CRTIMP ioinfo* __pioinfo[];
-
-/*
- * Definition of IOINFO_L2E, the log base 2 of the number of elements in each
- * array of ioinfo structs.
- */
-#define IOINFO_L2E	    5
-
-/*
- * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array
- */
-#define IOINFO_ARRAY_ELTS   (1 << IOINFO_L2E)
-
-/*
- * Access macros for getting at an ioinfo struct and its fields from a
- * file handle
- */
-#ifdef WIN32_DYN_IOINFO_SIZE
-#  define _pioinfo(i) ((intptr_t *) \
-     (((Size_t)__pioinfo[(i) >> IOINFO_L2E])/* * to head of array ioinfo [] */\
-      /* offset to the head of a particular ioinfo struct */ \
-      + (((i) & (IOINFO_ARRAY_ELTS - 1)) * w32_ioinfo_size)) \
-   )
-/* first slice of ioinfo is always the OS handle */
-#  define _osfhnd(i)  (*(_pioinfo(i)))
-#else
-#  define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1)))
-#  define _osfhnd(i)  (_pioinfo(i)->osfhnd)
-#endif
-
-/* since we are not doing a dup2(), this works fine */
-#define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = (intptr_t)osfh)
-
-#endif /* PERL_CORE */
-
-#endif /* !defined(_MSC_VER) || _MSC_VER<1900 */
-
 /* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */
 #if defined(PERL_EXT_IO) || defined(PERL_EXT_POSIX)
 #undef  PERLIO_NOT_STDIO
diff --git a/win32/win32sck.c b/win32/win32sck.c
index f08b7bea29..4edd1407a4 100644
--- a/win32/win32sck.c
+++ b/win32/win32sck.c
@@ -632,80 +632,6 @@ win32_socket(int af, int type, int protocol)
     return s;
 }
 
-/*
- * close RTL fd while respecting sockets
- * added as temporary measure until PerlIO has real
- * Win32 native layer
- *   -- BKS, 11-11-2000
-*/
-
-int my_close(int fd)
-{
-    int osf;
-    osf = TO_SOCKET(fd);/* Get it now before it's gone! */
-    if (osf != -1) {
-        int err;
-        err = closesocket(osf);
-        if (err == 0) {
-#ifdef _set_osfhnd
-            assert(_osfhnd(fd) == osf); /* catch a bad ioinfo struct def */
-            /* don't close freed handle */
-            _set_osfhnd(fd, INVALID_HANDLE_VALUE);
-            return close(fd);
-#else
-            (void)close(fd);    /* handle already closed, ignore error */
-            return 0;
-#endif
-        }
-        else if (err == SOCKET_ERROR) {
-            int wsaerr = WSAGetLastError();
-            err = convert_wsa_error_to_errno(wsaerr);
-            if (err != ENOTSOCK) {
-                (void)close(fd);
-                errno = err;
-                SetLastError(wsaerr);
-                return EOF;
-            }
-        }
-    }
-    return close(fd);
-}
-
-#undef fclose
-int
-my_fclose (FILE *pf)
-{
-    int osf;
-    osf = TO_SOCKET(win32_fileno(pf));/* Get it now before it's gone! */
-    if (osf != -1) {
-        int err;
-        win32_fflush(pf);
-        err = closesocket(osf);
-        if (err == 0) {
-#ifdef _set_osfhnd
-            assert(_osfhnd(win32_fileno(pf)) == osf); /* catch a bad ioinfo struct def */
-            /* don't close freed handle */
-            _set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE);
-            return fclose(pf);
-#else
-            (void)fclose(pf);   /* handle already closed, ignore error */
-            return 0;
-#endif
-        }
-        else if (err == SOCKET_ERROR) {
-            int wsaerr = WSAGetLastError();
-            err = convert_wsa_error_to_errno(wsaerr);
-            if (err != ENOTSOCK) {
-                (void)fclose(pf);
-                errno = err;
-                SetLastError(wsaerr);
-                return EOF;
-            }
-        }
-    }
-    return fclose(pf);
-}
-
 struct hostent *
 win32_gethostbyaddr(const char *addr, int len, int type)
 {