close($pipe_read_fh) hangs on Windows if another process is in read of same handle

[nmisch]

This is a bug report for perl from noah@leadboat.com,
generated with the help of perlbug 1.42 running under perl 5.32.1.

---

Steps to Reproduce
Test program:

#! /usr/bin/perl

use strict;
use warnings;
use Win32 ();
use Win32::Process ();
use Win32::ShellQuote ();
use Win32API::File qw(
  FdGetOsFHandle
  SetHandleInformation
  HANDLE_FLAG_INHERIT
);
$| = 1;
# Ensure win32sck.c::my_close() takes the wsock_started path, which is needed to
# witness the bug.  This program doesn't otherwise use sockets.
require Socket;

# Make an inheritable w32 handle for the read end of a pipe.
pipe my $read_fh, my $write_fh;
my $read_h = FdGetOsFHandle fileno($read_fh);
SetHandleInformation($read_h, HANDLE_FLAG_INHERIT, 1);

# Source code for a kid that receives the handle and reads from it.
my $kid_program = <<\_EOPERL;
use Win32API::File qw(OsFHandleOpen);
$| = 1;
my $h = shift;
print "kid start handle=$h\n";
close STDIN;
OsFHandleOpen(\*STDIN, $h, 'r')
  or die "$! opening STDIN as Win32 handle $h in $$";
# sleep 2;  # effective workaround: give parent time to close($read_fh)
print "gotline: $_" while (<>);  # hangs (non-bug or not the bug being reported)
print "(unreachable) kid exit\n";
_EOPERL

# Start that kid.
my $process;
Win32::Process::Create(
  $process,
  $^X,
  Win32::ShellQuote::quote_native($^X, '-e', $kid_program, $read_h),
  1,    ## Inherit handles
  0,    ## Inherit parent priority class
  ".",
)
or do {
  my $err = Win32::FormatMessage( Win32::GetLastError() );
  die "$err: Win32::Process::Create()";
};

sleep 1;  # give kid time to block on the pipe read
print "before close(\$read_fh) in $$\n";
if ($ENV{USE_WORKAROUND}) {
  # dup2() does a close()-like operation internally.  Since that does not route
  # through win32sck.c::my_close(), it bypasses any bug there.  This workaround
  # replaces the pipe FD with a non-pipe FD, and closing the non-pipe FD is
  # uneventful.
  require POSIX;
  POSIX::dup2(2, fileno $read_fh);
}
close $read_fh;  # without workaround, hangs forever (bug)
print "after close(\$read_fh)\n";
print $write_fh "foo\n";
close $write_fh;
print "parent exit\n";

Expected behavior

I expected to see a line saying "parent exit", but the last output line
started with "before close". Setting USE_WORKAROUND=1 in the environment
makes the program reach "parent exit", achieving that expectation. I
distilled the test program from cpan-authors/IPC-Run#77.

Non-debug stack trace of hang

Thread 1 (Thread 4352.0x1588):
#0  0x00007ff828a3f854 in ntdll!ZwDeviceIoControlFile () from C:\Windows\SYSTEM32\ntdll.dll
#1  0x00007ff82547fbe8 in Tcpip4_WSHStringToAddress () from C:\Windows\system32\mswsock.dll
#2  0x00007ff8254763cb in ?? () from C:\Windows\system32\mswsock.dll
#3  0x00007ff82547c336 in NSPStartup () from C:\Windows\system32\mswsock.dll
#4  0x00007ff827550bce in WSCWriteNameSpaceOrder32 () from C:\Windows\System32\ws2_32.dll
#5  0x00007ff82752afd2 in WSASendTo () from C:\Windows\System32\ws2_32.dll
#6  0x0000000065902508 in win32_socket () from C:\Strawberry64_532\perl\bin\perl532.dll
#7  0x00000000658f8930 in perl532!PerlIO_init () from C:\Strawberry64_532\perl\bin\perl532.dll
#8  0x00000000658f7d09 in perl532!PerlIOBase_close () from C:\Strawberry64_532\perl\bin\perl532.dll
#9  0x00000000658f825e in perl532!PerlIOBuf_close () from C:\Strawberry64_532\perl\bin\perl532.dll
#10 0x00000000658f7d68 in perl532!PerlIOBase_close () from C:\Strawberry64_532\perl\bin\perl532.dll
#11 0x00000000658f7da2 in perl532!Perl_PerlIO_close () from C:\Strawberry64_532\perl\bin\perl532.dll
#12 0x00000000658aac5f in perl532!Perl_do_openn () from C:\Strawberry64_532\perl\bin\perl532.dll
#13 0x00000000658aaf5b in perl532!Perl_do_close () from C:\Strawberry64_532\perl\bin\perl532.dll
#14 0x000000006585bf17 in perl532!Perl_find_runcv () from C:\Strawberry64_532\perl\bin\perl532.dll
#15 0x00000000658dfdd6 in perl532!Perl_runops_standard () from C:\Strawberry64_532\perl\bin\perl532.dll
#16 0x0000000065890eb7 in perl_run () from C:\Strawberry64_532\perl\bin\perl532.dll
#17 0x00000000658f3ac8 in perl532!RunPerl () from C:\Strawberry64_532\perl\bin\perl532.dll

I think frame 6 is actually in my_close(), and the lack of debug symbols makes
that not show up here. win32_socket() is immediately before my_close() in the
source code.

Possible fixes

This trouble arises because my_close() assumes closesocket() will always
report WSAENOTSOCK for a non-socket. The first paragraph of the closesocket
documentation remarks says not to rely on that. A robust fix would be to
maintain a data structure recording the FDs Perl has assigned to sockets, then
call closesocket() only for FDs appearing therein. One alternative would be
to use strategies like https://stackoverflow.com/q/50979090 to evaluate
whether a descriptor is a socket. That alternative may be simpler or more
efficient, but it's harder to cite API documentation supporting an expectation
that it will continue to work.

Perl configuration

[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=core
    severity=medium
---
Site configuration information for perl 5.32.1:

Configured by strawberry-perl at Sun Jan 24 15:01:28 2021.

Summary of my perl5 (revision 5 version 32 subversion 1) configuration:
   
  Platform:
    osname=MSWin32
    osvers=10.0.19042.746
    archname=MSWin32-x64-multi-thread
    uname='Win32 strawberry-perl 5.32.1.1 #1 Sun Jan 24 15:00:15 2021 x64'
    config_args='undef'
    hint=recommended
    useposix=true
    d_sigaction=undef
    useithreads=define
    usemultiplicity=define
    use64bitint=define
    use64bitall=undef
    uselongdouble=undef
    usemymalloc=n
    default_inc_excludes_dot=define
    bincompat5005=undef
  Compiler:
    cc='gcc'
    ccflags =' -DWIN32 -DWIN64 -D__USE_MINGW_ANSI_STDIO -DPERL_TEXTMODE_SCRIPTS -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -fwrapv -fno-strict-aliasing -mms-bitfields'
    optimize='-s -O2'
    cppflags='-DWIN32'
    ccversion=''
    gccversion='8.3.0'
    gccosandvers=''
    intsize=4
    longsize=4
    ptrsize=8
    doublesize=8
    byteorder=12345678
    doublekind=3
    d_longlong=define
    longlongsize=8
    d_longdbl=define
    longdblsize=16
    longdblkind=3
    ivtype='long long'
    ivsize=8
    nvtype='double'
    nvsize=8
    Off_t='long long'
    lseeksize=8
    alignbytes=8
    prototype=define
  Linker and Libraries:
    ld='g++'
    ldflags ='-s -L"C:\STRAWB~1\perl\lib\CORE" -L"C:\STRAWB~1\c\lib"'
    libpth=C:\STRAWB~1\c\lib C:\STRAWB~1\c\x86_64-w64-mingw32\lib C:\STRAWB~1\c\lib\gcc\x86_64-w64-mingw32\8.3.0
    libs= -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
    perllibs= -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
    libc=
    so=dll
    useshrplib=true
    libperl=libperl532.a
    gnulibc_version=''
  Dynamic Linking:
    dlsrc=dl_win32.xs
    dlext=xs.dll
    d_dlsymun=undef
    ccdlflags=' '
    cccdlflags=' '
    lddlflags='-mdll -s -L"C:\STRAWB~1\perl\lib\CORE" -L"C:\STRAWB~1\c\lib"'


---
@INC for perl 5.32.1:
    C:/Strawberry64_532/perl/site/lib
    C:/Strawberry64_532/perl/vendor/lib
    C:/Strawberry64_532/perl/lib

---
Environment for perl 5.32.1:
    HOME (unset)
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=C:\Windows\system32;C:\Windows;C:\Windows\System32\Wbem;C:\Windows\System32\WindowsPowerShell\v1.0\;C:\Windows\System32\OpenSSH\;C:\ProgramData\GooGet;C:\Program Files\Google\Compute Engine\metadata_scripts;C:\Program Files (x86)\Google\Cloud SDK\google-cloud-sdk\bin;C:\Program Files\PowerShell\7\;C:\Program Files\Google\Compute Engine\sysprep;C:\Strawberry64_532\c\bin;C:\Strawberry64_532\perl\site\bin;C:\Strawberry64_532\perl\bin;C:\Users\noah\AppData\Local\Microsoft\WindowsApps;
    PERL_BADLANG (unset)
    SHELL (unset)

[xenu]

This PR will fix it: #20922