diff options
| -rw-r--r-- | perlio.c | 31 | ||||
| -rw-r--r-- | perliol.h | 1 | ||||
| -rw-r--r-- | pod/perldiag.pod | 5 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 4 | ||||
| -rw-r--r-- | t/op/threads.t | 12 | ||||
| -rw-r--r-- | util.c | 19 |
6 files changed, 67 insertions, 5 deletions
@@ -2455,6 +2455,37 @@ PerlIOUnix_refcnt_dec(int fd) return cnt; } +int +PerlIOUnix_refcnt(int fd) +{ + dTHX; + int cnt = 0; + if (fd >= 0) { + dVAR; +#ifdef USE_ITHREADS + MUTEX_LOCK(&PL_perlio_mutex); +#endif + if (fd >= PL_perlio_fd_refcnt_size) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", + fd, PL_perlio_fd_refcnt_size); + } + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + cnt = PL_perlio_fd_refcnt[fd]; +#ifdef USE_ITHREADS + MUTEX_UNLOCK(&PL_perlio_mutex); +#endif + } else { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); + } + return cnt; +} + void PerlIO_cleanup(pTHX) { @@ -279,6 +279,7 @@ PERL_EXPORT_C IV PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV PERL_EXPORT_C SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); PERL_EXPORT_C int PerlIOUnix_refcnt_dec(int fd); PERL_EXPORT_C void PerlIOUnix_refcnt_inc(int fd); +PERL_EXPORT_C int PerlIOUnix_refcnt(int fd); PERL_EXPORT_C IV PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence); PERL_EXPORT_C Off_t PerlIOUnix_tell(pTHX_ PerlIO *f); PERL_EXPORT_C SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 1c259eece5..7a3b962451 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3906,6 +3906,11 @@ which is why it's currently left out of your copy. believes it found an infinite loop in the C<@ISA> hierarchy. This is a crude check that bails out after 100 levels of C<@ISA> depth. +=item refcnt: fd %d%s + +(P) Perl's I/O implementation failed an internal consistency check. If +you see this message, something is very wrong. + =item Reference found where even-sized list expected (W misc) You gave a single reference where Perl was expecting a list diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index d85b3d7fd0..2047dd6047 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -910,6 +910,10 @@ on the pipe to exit--in case you wish to look at the output of the pipe afterwards--and implicitly puts the exit status value of that command into C<$?> and C<${^CHILD_ERROR_NATIVE}>. +If there are multiple threads running, C<close> on a filehandle from a +piped open returns true without waiting for the child process to terminate, +if the filehandle is still open in another thread. + Closing the read end of a pipe before the process writing to it at the other end is done writing results in the writer receiving a SIGPIPE. If the other end can't handle that, be sure to read all the data before diff --git a/t/op/threads.t b/t/op/threads.t index 240c00f7c6..4b731f07f9 100644 --- a/t/op/threads.t +++ b/t/op/threads.t @@ -16,7 +16,7 @@ BEGIN { exit 0; } - plan(23); + plan(24); } use strict; @@ -349,4 +349,14 @@ threads->create( EOI +# [perl #78494] Pipes shared between threads block when closed +watchdog 10; +{ + my $perl = which_perl; + $perl = qq'"$perl"' if $perl =~ /\s/; + open(my $OUT, "|$perl") || die("ERROR: $!"); + threads->create(sub { })->join; + ok(1, "Pipes shared between threads do not block when closed"); +} + # EOF @@ -25,6 +25,8 @@ #define PERL_IN_UTIL_C #include "perl.h" +#include "perliol.h" /* For PerlIOUnix_refcnt */ + #ifndef PERL_MICRO #include <signal.h> #ifndef SIG_ERR @@ -3118,11 +3120,16 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) int status; SV **svp; Pid_t pid; - Pid_t pid2; + Pid_t pid2 = 0; bool close_failed; dSAVEDERRNO; + const int fd = PerlIO_fileno(ptr); + + /* Find out whether the refcount is low enough for us to wait for the + child proc without blocking. */ + const bool should_wait = PerlIOUnix_refcnt(fd) == 1; - svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); + svp = av_fetch(PL_fdpid,fd,TRUE); pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -3141,7 +3148,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat); rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat); #endif - do { + if (should_wait) do { pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); #ifndef PERL_MICRO @@ -3153,7 +3160,11 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) RESTORE_ERRNO; return -1; } - return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); + return( + should_wait + ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status) + : 0 + ); } #else #if defined(__LIBCATAMOUNT__) |