Reset errno after failed piped close

(this is the same change as commit 00db273fa22ecba6466df777a772c6017c403a96, but as applied)

5 files changed, 73 insertions, 10 deletions

diff --git a/lib/Time/gmtime.pm b/lib/Time/gmtime.pm
index 7ca12bb981..c1d11d74db 100644
--- a/lib/Time/gmtime.pm
+++ b/lib/Time/gmtime.pm
@@ -4,7 +4,7 @@ use Time::tm;
 
 BEGIN { 
     use Exporter   ();
-    use vars       qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+    use vars       qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
     @ISA         = qw(Exporter Time::tm);
     @EXPORT      = qw(gmtime gmctime);
     @EXPORT_OK   = qw(  
@@ -13,6 +13,7 @@ BEGIN {
 			$tm_isdst
 		    );
     %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+    $VERSION     = 1.01;
 }
 use vars      @EXPORT_OK;
 
@@ -27,8 +28,8 @@ sub populate (@) {
     return $tmob;
 } 
 
-sub gmtime (;$)    { populate CORE::gmtime(shift||time)}
-sub gmctime (;$)   { scalar   CORE::gmtime(shift||time)} 
+sub gmtime (;$)    { populate CORE::gmtime(@_ ? shift : time)}
+sub gmctime (;$)   { scalar   CORE::gmtime(@_ ? shift : time)} 
 
 1;
 __END__
diff --git a/lib/Time/localtime.pm b/lib/Time/localtime.pm
index 8d72da159a..9437752597 100644
--- a/lib/Time/localtime.pm
+++ b/lib/Time/localtime.pm
@@ -4,7 +4,7 @@ use Time::tm;
 
 BEGIN { 
     use Exporter   ();
-    use vars       qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+    use vars       qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
     @ISA         = qw(Exporter Time::tm);
     @EXPORT      = qw(localtime ctime);
     @EXPORT_OK   = qw(  
@@ -13,6 +13,7 @@ BEGIN {
 			$tm_isdst
 		    );
     %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+    $VERSION     = 1.01;
 }
 use vars      @EXPORT_OK;
 
@@ -27,8 +28,8 @@ sub populate (@) {
     return $tmob;
 } 
 
-sub localtime (;$) { populate CORE::localtime(shift||time)}
-sub ctime (;$)     { scalar   CORE::localtime(shift||time) } 
+sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)}
+sub ctime (;$)     { scalar   CORE::localtime(@_ ? shift : time) } 
 
 1;
 
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index a99dffeb4d..823355b363 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -551,7 +551,11 @@ omitted, does chroot to $_.
 
 Closes the file or pipe associated with the file handle, returning TRUE
 only if stdio successfully flushes buffers and closes the system file
-descriptor.  You don't have to close FILEHANDLE if you are immediately
+descriptor.  If the file handle came from a piped open C<close> will
+additionally return FALSE if one of the other system calls involved
+fails or if the program exits with non-zero status.  (If the problem was
+that the program exited non-zero $! will be set to 0.)
+You don't have to close FILEHANDLE if you are immediately
 going to do another open() on it, because open() will close it for you.  (See
 open().)  However, an explicit close on an input file resets the line
 counter ($.), while the implicit close done by open() does not.  Also,
diff --git a/t/io/pipe.t b/t/io/pipe.t
index d70b2ab258..21f02a789a 100755
--- a/t/io/pipe.t
+++ b/t/io/pipe.t
@@ -13,7 +13,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..8\n";
+print "1..10\n";
 
 open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
 print PIPE "Xk 1\n";
@@ -64,3 +64,46 @@ print WRITER "not ok 7\n";
 close WRITER;
 
 print "ok 8\n";
+
+# VMS doesn't like spawning subprocesses that are still connected to
+# STDOUT.  Someone should modify tests #9 and #10 to work with VMS.
+
+if ($^O eq 'VMS') {
+    print "ok 9\n";
+    print "ok 10\n";
+    exit;
+}
+
+if ($Config{d_sfio}) {
+    # Sfio doesn't report failure when closing a broken pipe
+    # that has pending output.  Go figure.
+    print "ok 9\n";
+}
+else {
+    local $SIG{PIPE} = 'IGNORE';
+    open NIL, '|true'	or die "open failed: $!";
+    sleep 2;
+    print NIL 'foo'	or die "print failed: $!";
+    if (close NIL) {
+	print "not ok 9\n";
+    }
+    else {
+	print "ok 9\n";
+    }
+}
+
+# check that errno gets forced to 0 if the piped program exited non-zero
+open NIL, '|exit 23;' or die "fork failed: $!";
+$! = 1;
+if (close NIL) {
+    print "not ok 10\n# successful close\n";
+}
+elsif ($! != 0) {
+    print "not ok 10\n# errno $!\n";
+}
+elsif ($? == 0) {
+    print "not ok 10\n# status 0\n";
+}
+else {
+    print "ok 10\n";
+}
diff --git a/util.c b/util.c
index e78ad82863..2ee9c0ef90 100644
--- a/util.c
+++ b/util.c
@@ -1964,6 +1964,11 @@ PerlIO *ptr;
     int status;
     SV **svp;
     int pid;
+    bool close_failed;
+    int saved_errno;
+#ifdef VMS
+    int saved_vaxc_errno;
+#endif
 
     svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
     pid = (int)SvIVX(*svp);
@@ -1974,7 +1979,12 @@ PerlIO *ptr;
 	return my_syspclose(ptr);
     }
 #endif 
-    PerlIO_close(ptr);
+    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
+	saved_errno = errno;
+#ifdef VMS
+	saved_vaxc_errno = vaxc$errno;
+#endif
+    }
 #ifdef UTS
     if(kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
@@ -1987,7 +1997,11 @@ PerlIO *ptr;
     rsignal_restore(SIGHUP, &hstat);
     rsignal_restore(SIGINT, &istat);
     rsignal_restore(SIGQUIT, &qstat);
-    return(pid < 0 ? pid : status);
+    if (close_failed) {
+	SETERRNO(saved_errno, saved_vaxc_errno);
+	return -1;
+    }
+    return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
 }
 #endif /* !DOSISH */