Win32: eliminate the sys_intern fdpid aka w32_fdpid

doio.c

@@ -1089,9 +1089,6 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
             }
 #endif
 
-#if !defined(WIN32)
-           /* PL_fdpid isn't used on Windows, so avoid this useless work.
-            * XXX Probably the same for a lot of other places. */
             {
                 Pid_t pid;
                 SV *sv;
@@ -1104,7 +1101,6 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
                 SvUPGRADE(sv, SVt_IV);
                 SvIV_set(sv, pid);
             }
-#endif
 
             if (was_fdopen) {
                 /* need to close fp without closing underlying fd */

pod/perldelta.pod

@@ -388,6 +388,11 @@ This has now been fixed, and runs as expected. ([GH #23064]).
         say "This line would never run";
     }
 
+=item *
+
+C<close(STDOUT)> when C<STDOUT> has been opened as a pipe will now
+properly wait for the child to exit on Windows.  [GH #4106]
+
 =back
 
 =head1 Known Problems

t/io/closepid.t

@@ -6,9 +6,6 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan tests => 3;
-watchdog(10, $^O eq 'MSWin32' ? "alarm" : '');
-
 use Config;
 $| = 1;
 $SIG{PIPE} = 'IGNORE';
@@ -21,10 +18,25 @@ my $perl = which_perl();
 my $killsig = 'HUP';
 $killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/;
 
+{
+    # github #4106
+    open my $saveout, ">&", \*STDOUT or die;
+    my $start = time();
+    open STDOUT, "|-", $perl, "-e", "sleep 2"
+        or die;
+    print STDOUT "Hi\n" for 1..2;
+    my $close_ok = close STDOUT;
+    open STDOUT, ">&", $saveout;
+    ok($close_ok, "close pipe to child success");
+    cmp_ok(time(), '>', $start, "close waited at least a bit");
+}
+
+watchdog(10, $^O eq 'MSWin32' ? "alarm" : '');
+
 SKIP:
 {
     skip("Not relevant to $^O", 3)
-      if $^O eq "MSWin32" || $^O eq "VMS";
+        if $^O eq "VMS";
     skip("only matters for waitpid or wait4", 3)
       unless $Config{d_waitpid} || $Config{d_wait4};
     # [perl #119893]
@@ -42,3 +54,5 @@ SKIP:
     kill $killsig, $pid;
     open STDIN, "<&", $savein;
 }
+
+done_testing();

win32/win32.c

@@ -43,8 +43,6 @@
 /* #include "config.h" */
 
 
-#define PerlIO FILE
-
 #include <sys/stat.h>
 #include "EXTERN.h"
 #include "perl.h"
@@ -53,6 +51,8 @@
 #define PERL_NO_GET_CONTEXT
 #include "XSUB.h"
 
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+
 #include <fcntl.h>
 #ifndef __GNUC__
 /* assert.h conflicts with #define of assert in perl.h */
@@ -3624,7 +3624,7 @@ do_popen(const char *mode, const char *command, IV narg, SV **args) {
 
         win32_close(p[child]);
 
-        sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
+        sv_setiv(*av_fetch(PL_fdpid, p[parent], TRUE), childpid);
 
         /* set process id so that it can be returned by perl's open() */
         PL_forkprocess = childpid;
@@ -3667,34 +3667,40 @@ win32_pclose(PerlIO *pf)
 #ifdef USE_RTL_POPEN
     return _pclose(pf);
 #else
+    /* this should roughly match Perl_my_pclose() in util.c */
     dTHX;
-    int childpid, status;
-    SV *sv;
+    int fd = PerlIO_fileno(pf);
 
-    sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
-
-    if (SvIOK(sv))
-        childpid = SvIVX(sv);
+    SV **svp = av_fetch(PL_fdpid, fd, FALSE);
+    int childpid;
+    if (svp) {
+        childpid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
+        SvREFCNT_dec(*svp);
+        *svp = NULL;
+    }
     else
-        childpid = 0;
+        childpid = -1;
 
-    if (!childpid) {
-        errno = EBADF;
-        return -1;
-    }
+    bool should_wait = PerlIOUnix_refcnt(fd) == 1 && childpid > 0;
 
-#ifdef USE_PERLIO
-    PerlIO_close(pf);
-#else
-    fclose(pf);
-#endif
-    SvIVX(sv) = 0;
+    bool close_failed = (PerlIO_close(pf) == EOF);
 
-    if (win32_waitpid(childpid, &status, 0) == -1)
-        return -1;
+    int status;
+    dSAVE_ERRNO;
+    int wait_result;
+    if (should_wait) {
+        wait_result = win32_waitpid(childpid, &status, 0);
+    }
 
-    return status;
+    if (close_failed) {
+        RESTORE_ERRNO; /* error from the close */
+        return -1;
+    }
 
+    return should_wait
+        ? (wait_result < 0 ? wait_result :
+           (status == 0 ? 0 : (errno = 0, status)))
+        : 0;
 #endif /* USE_RTL_POPEN */
 }
 
@@ -5687,7 +5693,6 @@ Perl_sys_intern_init(pTHX)
     w32_perlshell_tokens	= NULL;
     w32_perlshell_vec		= (char**)NULL;
     w32_perlshell_items		= 0;
-    w32_fdpid			= newAV();
     Newx(w32_children, 1, child_tab);
     w32_num_children		= 0;
 #  ifdef USE_ITHREADS
@@ -5730,7 +5735,6 @@ Perl_sys_intern_clear(pTHX)
 
     Safefree(w32_perlshell_tokens);
     Safefree(w32_perlshell_vec);
-    /* NOTE: w32_fdpid is freed by sv_clean_all() */
     Safefree(w32_children);
     if (w32_timerid) {
         KillTimer(w32_message_hwnd, w32_timerid);
@@ -5769,7 +5773,6 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
     dst->perlshell_tokens	= NULL;
     dst->perlshell_vec		= (char**)NULL;
     dst->perlshell_items	= 0;
-    dst->fdpid			= newAV();
     Newxz(dst->children, 1, child_tab);
     dst->pseudo_id		= 0;
     dst->cur_tid = 0;

win32/win32.h

@@ -567,7 +567,6 @@ struct interp_intern {
     char *	perlshell_tokens;
     char **	perlshell_vec;
     long	perlshell_items;
-    struct av *	fdpid;
     child_tab *	children;
 #ifdef USE_ITHREADS
     DWORD	pseudo_id;