Allow child processes to continue after EPIPE

This ensures that if the child process closed its stdin and Emacs tries
to write to it, the process can still do any remaining work and exit
normally.  In practice, this can occur with commands like "head(1)"
(bug#79079).

* src/fileio.c (file_for_stream): New function, extracted from...
(Fset_binary_mode): ... here.
(Ffile__close_stream): New function.

* src/process.c (send_process): When encountering EPIPE, only close the
fd for the pipe to the child process's stdin.

* lisp/eshell/esh-io.el (eshell-output-object-to-target): Don't check
for process liveness anymore.

* test/src/process-tests.el (process-tests/broken-pipe): New function.
(process-tests/broken-pipe/pipe, process-tests/broken-pipe/pty)
(process-tests/broken-pipe/pipe-stdin)
(process-tests/broken-pipe/pty-stdin): New tests.

* etc/NEWS: Announce this change.

etc/NEWS

@@ -30,6 +30,13 @@ applies, and please also update docstrings as needed.
 
 * Changes in Emacs 32.1
 
+---
+** Emacs no longer kills child processes after EPIPE.
+Previously, Emacs would immediately kill a child process and set its
+exit status to 256 if sending input to that process returned EPIPE.
+Now when this happens, Emacs closes the file descriptor to write to the
+child process, but allows it to continue execution as normal.
+
 
 * Editing Changes in Emacs 32.1
 

lisp/eshell/esh-io.el

@@ -741,18 +741,14 @@ Returns what was actually sent, or nil if nothing was sent.")
   "Output OBJECT to the process TARGET."
   (unless (stringp object)
     (setq object (eshell-stringify object)))
-  (condition-case err
+  (condition-case _
       (process-send-string target object)
     (error
-     ;; If `process-send-string' raises an error and the process has
+     ;; NOTE: When running Emacs in batch mode (e.g. during regression
-     ;; finished, treat it as a broken pipe.  Otherwise, just re-raise
+     ;; tests), Emacs can abort due to SIGPIPE here.  Maybe
-     ;; the signal.  NOTE: When running Emacs in batch mode
+     ;; `process-send-string' should handle SIGPIPE even in batch mode
-     ;; (e.g. during regression tests), Emacs can abort due to SIGPIPE
+     ;; (bug#66186).
-     ;; here.  Maybe `process-send-string' should handle SIGPIPE even
+     (signal 'eshell-pipe-broken (list target))))
-     ;; in batch mode (bug#66186).
-     (if (process-live-p target)
-         (signal err)
-       (signal 'eshell-pipe-broken (list target)))))
   object)
 
 (cl-defmethod eshell-output-object-to-target (object

src/fileio.c

@@ -6572,6 +6572,19 @@ before any other event (mouse or keypress) is handled.  */)
 }
 
 
+static FILE *
+file_for_stream (Lisp_Object stream)
+{
+  if (EQ (stream, Qstdin))
+    return stdin;
+  else if (EQ (stream, Qstdout))
+    return stdout;
+  else if (EQ (stream, Qstderr))
+    return stderr;
+  else
+    xsignal2 (Qerror, build_string ("unsupported stream"), stream);
+}
+
 DEFUN ("set-binary-mode", Fset_binary_mode, Sset_binary_mode, 2, 2, 0,
        doc: /* Switch STREAM to binary I/O mode or text I/O mode.
 STREAM can be one of the symbols `stdin', `stdout', or `stderr'.
@@ -6593,18 +6606,9 @@ On Posix systems, this function always returns non-nil, and has no
 effect except for flushing STREAM's data.  */)
   (Lisp_Object stream, Lisp_Object mode)
 {
-  FILE *fp = NULL;
-  int binmode;
-
   CHECK_SYMBOL (stream);
-  if (EQ (stream, Qstdin))
+  FILE *fp = file_for_stream (stream);
-    fp = stdin;
+  int binmode;
-  else if (EQ (stream, Qstdout))
-    fp = stdout;
-  else if (EQ (stream, Qstderr))
-    fp = stderr;
-  else
-    xsignal2 (Qerror, build_string ("unsupported stream"), stream);
 
   binmode = NILP (mode) ? O_TEXT : O_BINARY;
   if (fp != stdin)
@@ -6612,6 +6616,22 @@ effect except for flushing STREAM's data.  */)
 
   return (set_binary_mode (fileno (fp), binmode) == O_BINARY) ? Qt : Qnil;
 }
+
+DEFUN ("file--close-stream", Ffile__close_stream,
+       Sfile__close_stream, 1, 1, 0,
+       doc: /* Close the standard STREAM of the Emacs process.
+STREAM can be one of the symbols `stdin', `stdout', or `stderr'.
+
+This function is primarily intended for testing process machinery within
+Emacs.  */)
+  (Lisp_Object stream)
+{
+  CHECK_SYMBOL (stream);
+  FILE *fp = file_for_stream (stream);
+  fclose (fp);
+  return Qnil;
+}
+
 
 #ifndef DOS_NT
 
@@ -7047,6 +7067,7 @@ This includes interactive calls to `delete-file' and
   defsubr (&Snext_read_file_uses_dialog_p);
 
   defsubr (&Sset_binary_mode);
+  defsubr (&Sfile__close_stream);
 
 #ifndef DOS_NT
   defsubr (&Sfile_system_info);

src/process.c

@@ -6922,10 +6922,8 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len,
 		}
 	      else if (errno == EPIPE)
 		{
-		  p->raw_status_new = 0;
+		  close_process_fd (&p->open_fd[WRITE_TO_SUBPROCESS]);
-		  pset_status (p, list2 (Qexit, make_fixnum (256)));
+		  p->outfd = -1;
-		  p->tick = ++process_tick;
-		  deactivate_process (proc);
 		  error ("Process %s no longer connected to pipe; closed it",
 			 SDATA (p->name));
 		}

test/src/process-tests.el

@@ -1054,6 +1054,69 @@ Return nil if FILENAME doesn't exist."
                            (process-exit-status proc)
                            events))))))
 
+(defun process-tests/broken-pipe (connection-type)
+  "Test handling of broken pipes; see bug#79079.
+This test runs a shell script that reads a line of text and closes
+stdin.  We send two lines of text to the script; the second should
+signal an error indicating that the pipe has been closed.  The script
+should also run to completion, printing out the line of text it read."
+  (with-temp-buffer
+    (let ((saw-error nil)
+          (proc (make-process
+                 :name "test" :buffer (current-buffer)
+                 :command `(,(expand-file-name invocation-name
+                                               invocation-directory)
+                            "-Q" "--batch" "--eval"
+                            ,(prin1-to-string
+                              '(let ((line (read-string "")))
+                                 (file--close-stream 'stdin)
+                                 (message "closed stream")
+                                 (sit-for 1)
+                                 (message "%s" line))))
+                 :connection-type 'pipe)))
+      (process-send-string proc "hello\n")
+      (while (not (string-prefix-p "closed stream\n" (buffer-string)))
+        (accept-process-output))
+      (condition-case err
+          (process-send-string proc "extra\n")
+        (error
+         (setq saw-error t)
+         (should (string-match
+                  (rx bos "Process test" (? "<" (+ digit) ">")
+                      " no longer connected to pipe; closed it"
+                      eos)
+                  (error-message-string err)))))
+      (unless saw-error
+        (ert-fail "Expected error from `process-send-string'"))
+      ;; Wait for the process to finish, and check results.
+      (while (eq (process-status proc) 'run)
+        (accept-process-output))
+      (accept-process-output)
+      (should (eq (process-status proc) 'exit))
+      (should (eq (process-exit-status proc) 0))
+      (should (string-match
+               (rx bos "closed stream\nhello\n\nProcess test"
+                   (? "<" (+ digit) ">") " finished\n" eos)
+               (buffer-string))))))
+
+;; These tests only works when running Emacs interactively, since we
+;; don't catch SIGPIPE in batch mode.  TODO: Fixing bug#66186 would
+;; probably allow running these tests in batch mode.
+(when (not noninteractive)
+  (ert-deftest process-tests/broken-pipe/pipe ()
+    (process-tests/broken-pipe 'pipe))
+
+  ;; Emacs doesn't support PTYs on MS-Windows.
+  (unless (memq system-type '(ms-dos windows-nt))
+    (ert-deftest process-tests/broken-pipe/pty ()
+      (process-tests/broken-pipe 'pty))
+
+    (ert-deftest process-tests/broken-pipe/pipe-stdin ()
+      (process-tests/broken-pipe '(pipe . pty)))
+
+    (ert-deftest process-tests/broken-pipe/pty-stdin ()
+      (process-tests/broken-pipe '(pty . pipe)))))
+
 (ert-deftest process-num-processors ()
   "Sanity checks for num-processors."
   (should (equal (num-processors) (num-processors)))