In gv.t, check that the installed $SIG{__DIE__} handler is never called.

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 414af22..dabc062 100644 (file)
--- a/util.c
+++ b/util.c
@@ -25,6 +25,10 @@
 #define PERL_IN_UTIL_C
 #include "perl.h"
 
+#ifdef USE_PERLIO
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+#endif
+
 #ifndef PERL_MICRO
 #include <signal.h>
 #ifndef SIG_ERR
@@ -3118,11 +3122,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 +3150,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 +3162,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__)
@@ -3844,7 +3857,7 @@ Perl_my_fflush_all(pTHX)
 }
 
 void
-Perl_report_wrongway_fh(pTHX_ const GV *gv, char have)
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
 {
     if (ckWARN(WARN_IO)) {
        const char * const name
@@ -3915,47 +3928,6 @@ Perl_report_evil_fh(pTHX_ const GV *gv)
     }
 }
 
-/* XXX Add documentation after final interface and behavior is decided */
-/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
-    U8 source = *current;
-
-    May want to add eg, WARN_REGEX
-*/
-
-char
-Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
-{
-
-    U8 result;
-
-    if (! isASCII(source)) {
-       Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
-    }
-
-    result = toCTRL(source);
-    if (! isCNTRL(result)) {
-       if (source == '{') {
-           Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
-       }
-       else if (output_warning) {
-           U8 clearer[3];
-           U8 i = 0;
-           if (! isALNUM(result)) {
-               clearer[i++] = '\\';
-           }
-           clearer[i++] = result;
-           clearer[i++] = '\0';
-
-           Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                           "\"\\c%c\" more clearly written simply as \"%s\"",
-                           source,
-                           clearer);
-       }
-    }
-
-    return result;
-}
-
 /* To workaround core dumps from the uninitialised tm_zone we get the
  * system to give us a reasonable struct to copy.  This fix means that
  * strftime uses the tm_zone and tm_gmtoff values returned by