[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master d7b89ea407 1/2: Allow creating processes where only one of stdin
|
From: |
Jim Porter |
|
Subject: |
master d7b89ea407 1/2: Allow creating processes where only one of stdin or stdout is a PTY |
|
Date: |
Fri, 5 Aug 2022 21:06:07 -0400 (EDT) |
branch: master
commit d7b89ea4077d4fe677ba0577245328819ee79cdc
Author: Jim Porter <jporterbugs@gmail.com>
Commit: Jim Porter <jporterbugs@gmail.com>
Allow creating processes where only one of stdin or stdout is a PTY
* src/lisp.h (emacs_spawn):
* src/callproc.c (emacs_spawn): Add PTY_IN and PTY_OUT arguments to
specify which streams should be set up as a PTY.
(call_process): Adjust call to 'emacs_spawn'.
* src/process.h (Lisp_Process): Replace 'pty_flag' with 'pty_in' and
'pty_out'.
* src/process.c (is_pty_from_symbol): New function.
(make-process): Allow :connection-type to be a cons cell, and allow
using a stderr process with a PTY for stdin/stdout.
(create_process): Handle creating a process where only one of stdin or
stdout is a PTY.
* lisp/eshell/esh-proc.el (eshell-needs-pipe, eshell-needs-pipe-p):
Remove.
(eshell-gather-process-output): Use 'make-process' and set
':connection-type' as needed by the value of 'eshell-in-pipeline-p'.
* lisp/net/tramp.el (tramp-handle-make-process):
* lisp/net/tramp-adb.el (tramp-adb-handle-make-process):
* lisp/net/tramp-sh.el (tramp-sh-handle-make-process): Don't signal an
error when ':connection-type' is a cons cell.
* test/src/process-tests.el
(process-test-sentinel-wait-function-working-p): Allow passing PROC
in, and rework into...
(process-test-wait-for-sentinel): ... this.
(process-test-sentinel-accept-process-output)
(process-test-sentinel-sit-for, process-test-quoted-batfile)
(process-test-stderr-filter): Use 'process-test-wait-for-sentinel'.
(make/process/test-connection-type): New function.
(make-process/connection-type/pty, make-process/connection-type/pty-2)
(make-process/connection-type/pipe)
(make-process/connection-type/pipe-2)
(make-process/connection-type/in-pty)
(make-process/connection-type/out-pty)
(make-process/connection-type/pty-with-stderr-buffer)
(make-process/connection-type/out-pty-with-stderr-buffer): New tests.
* test/lisp/eshell/esh-proc-tests.el (esh-proc-test--detect-pty-cmd):
New variable.
(esh-proc-test/pipeline-connection-type/no-pipeline)
(esh-proc-test/pipeline-connection-type/first)
(esh-proc-test/pipeline-connection-type/middle)
(esh-proc-test/pipeline-connection-type/last): New tests.
* doc/lispref/processes.texi (Asynchronous Processes): Document new
':connection-type' behavior.
(Output from Processes): Remove caveat about ':stderr' forcing
'make-process' to use pipes.
* etc/NEWS: Announce this change (bug#56025).
---
doc/lispref/processes.texi | 28 +++-----
etc/NEWS | 12 ++++
lisp/eshell/esh-proc.el | 55 ++++++----------
lisp/net/tramp-adb.el | 5 +-
lisp/net/tramp-sh.el | 5 +-
lisp/net/tramp.el | 5 +-
src/callproc.c | 37 ++++++-----
src/lisp.h | 3 +-
src/process.c | 129 +++++++++++++++++++++++--------------
src/process.h | 5 +-
test/lisp/eshell/esh-proc-tests.el | 43 +++++++++++++
test/src/process-tests.el | 121 ++++++++++++++++++++++++----------
12 files changed, 288 insertions(+), 160 deletions(-)
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 1ef8fc3d03..e253ab9de0 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -705,12 +705,13 @@ coding system will apply. @xref{Default Coding Systems}.
Initialize the type of device used to communicate with the subprocess.
Possible values are @code{pty} to use a pty, @code{pipe} to use a
pipe, or @code{nil} to use the default derived from the value of the
-@code{process-connection-type} variable. This parameter and the value
-of @code{process-connection-type} are ignored if a non-@code{nil}
-value is specified for the @code{:stderr} parameter; in that case, the
-type will always be @code{pipe}. On systems where ptys are not
-available (MS-Windows), this parameter is likewise ignored, and pipes
-are used unconditionally.
+@code{process-connection-type} variable. If @var{type} is a cons cell
+@w{@code{(@var{input} . @var{output})}}, then @var{input} will be used
+for standard input and @var{output} for standard output (and standard
+error if @code{:stderr} is @code{nil}).
+
+On systems where ptys are not available (MS-Windows), this parameter
+is ignored, and pipes are used unconditionally.
@item :noquery @var{query-flag}
Initialize the process query flag to @var{query-flag}.
@@ -1530,20 +1531,11 @@ a buffer, which is called the associated buffer of the
process
default filter discards the output.
If the subprocess writes to its standard error stream, by default
-the error output is also passed to the process filter function. If
-Emacs uses a pseudo-TTY (pty) for communication with the subprocess,
-then it is impossible to separate the standard output and standard
-error streams of the subprocess, because a pseudo-TTY has only one
-output channel. In that case, if you want to keep the output to those
-streams separate, you should redirect one of them to a file---for
-example, by using an appropriate shell command via
-@code{start-process-shell-command} or a similar function.
-
- Alternatively, you could use the @code{:stderr} parameter with a
+the error output is also passed to the process filter function.
+Alternatively, you could use the @code{:stderr} parameter with a
non-@code{nil} value in a call to @code{make-process}
(@pxref{Asynchronous Processes, make-process}) to make the destination
-of the error output separate from the standard output; in that case,
-Emacs will use pipes for communicating with the subprocess.
+of the error output separate from the standard output.
When a subprocess terminates, Emacs reads any pending output,
then stops reading output from that subprocess. Therefore, if the
diff --git a/etc/NEWS b/etc/NEWS
index dc8bd6ce24..8a9744ab3e 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2332,6 +2332,12 @@ they will still be escaped, so the '.foo' symbol is
still printed as
and remapping parent of basic faces does not work reliably.
Instead of remapping 'mode-line', you have to remap 'mode-line-active'.
++++
+** 'make-process' has been extended to support ptys when ':stderr' is set.
+Previously, setting ':stderr' to a non-nil value would force the
+process's connection to use pipes. Now, Emacs will use a pty for
+stdin and stdout if requested no matter the value of ':stderr'.
+
---
** User option 'mail-source-ignore-errors' is now obsolete.
The whole mechanism for prompting users to continue in case of
@@ -3323,6 +3329,12 @@ translation.
This is useful when quoting shell arguments for a remote shell
invocation. Such shells are POSIX conformant by default.
++++
+** 'make-process' can set connection type independently for input and output.
+When calling 'make-process', communication via pty can be enabled
+selectively for just input or output by passing a cons cell for
+':connection-type', e.g. '(pipe . pty)'.
+
+++
** 'signal-process' now consults the list 'signal-process-functions'.
This is to determine which function has to be called in order to
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index 70426ccaf2..99b43661f2 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -250,30 +250,6 @@ The prompt will be set to PROMPT."
"A marker that tracks the beginning of output of the last subprocess.
Used only on systems which do not support async subprocesses.")
-(defvar eshell-needs-pipe
- '("bc"
- ;; xclip.el (in GNU ELPA) calls all of these with
- ;; `process-connection-type' set to nil.
- "pbpaste" "putclip" "xclip" "xsel" "wl-copy")
- "List of commands which need `process-connection-type' to be nil.
-Currently only affects commands in pipelines, and not those at
-the front. If an element contains a directory part it must match
-the full name of a command, otherwise just the nondirectory part must match.")
-
-(defun eshell-needs-pipe-p (command)
- "Return non-nil if COMMAND needs `process-connection-type' to be nil.
-See `eshell-needs-pipe'."
- (and (bound-and-true-p eshell-in-pipeline-p)
- (not (eq eshell-in-pipeline-p 'first))
- ;; FIXME should this return non-nil for anything that is
- ;; neither 'first nor 'last? See bug#1388 discussion.
- (catch 'found
- (dolist (exe eshell-needs-pipe)
- (if (string-equal exe (if (string-search "/" exe)
- command
- (file-name-nondirectory command)))
- (throw 'found t))))))
-
(defun eshell-gather-process-output (command args)
"Gather the output from COMMAND + ARGS."
(require 'esh-var)
@@ -290,31 +266,36 @@ See `eshell-needs-pipe'."
(cond
((fboundp 'make-process)
(setq proc
- (let ((process-connection-type
- (unless (eshell-needs-pipe-p command)
- process-connection-type))
- (command (file-local-name (expand-file-name command))))
- (apply #'start-file-process
- (file-name-nondirectory command) nil command args)))
+ (let ((command (file-local-name (expand-file-name command)))
+ (conn-type (pcase (bound-and-true-p eshell-in-pipeline-p)
+ ('first '(nil . pipe))
+ ('last '(pipe . nil))
+ ('t 'pipe)
+ ('nil nil))))
+ (make-process
+ :name (file-name-nondirectory command)
+ :buffer (current-buffer)
+ :command (cons command args)
+ :filter (if (eshell-interactive-output-p)
+ #'eshell-output-filter
+ #'eshell-insertion-filter)
+ :sentinel #'eshell-sentinel
+ :connection-type conn-type
+ :file-handler t)))
(eshell-record-process-object proc)
- (set-process-buffer proc (current-buffer))
- (set-process-filter proc (if (eshell-interactive-output-p)
- #'eshell-output-filter
- #'eshell-insertion-filter))
- (set-process-sentinel proc #'eshell-sentinel)
(run-hook-with-args 'eshell-exec-hook proc)
(when (fboundp 'process-coding-system)
(let ((coding-systems (process-coding-system proc)))
(setq decoding (car coding-systems)
encoding (cdr coding-systems)))
- ;; If start-process decided to use some coding system for
+ ;; If `make-process' decided to use some coding system for
;; decoding data sent from the process and the coding system
;; doesn't specify EOL conversion, we had better convert CRLF
;; to LF.
(if (vectorp (coding-system-eol-type decoding))
(setq decoding (coding-system-change-eol-conversion decoding 'dos)
changed t))
- ;; Even if start-process left the coding system for encoding
+ ;; Even if `make-process' left the coding system for encoding
;; data sent from the process undecided, we had better use the
;; same one as what we use for decoding. But, we should
;; suppress EOL conversion.
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index ef0cc2d66c..918de68ea9 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -877,7 +877,10 @@ implementation will be used."
(signal 'wrong-type-argument (list #'symbolp coding)))
(when (eq connection-type t)
(setq connection-type 'pty))
- (unless (memq connection-type '(nil pipe pty))
+ (unless (or (and (consp connection-type)
+ (memq (car connection-type) '(nil pipe pty))
+ (memq (cdr connection-type) '(nil pipe pty)))
+ (memq connection-type '(nil pipe pty)))
(signal 'wrong-type-argument (list #'symbolp connection-type)))
(unless (or (null filter) (eq filter t) (functionp filter))
(signal 'wrong-type-argument (list #'functionp filter)))
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 9e5347252a..38fffadd4e 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -2842,7 +2842,10 @@ implementation will be used."
(signal 'wrong-type-argument (list #'symbolp coding)))
(when (eq connection-type t)
(setq connection-type 'pty))
- (unless (memq connection-type '(nil pipe pty))
+ (unless (or (and (consp connection-type)
+ (memq (car connection-type) '(nil pipe pty))
+ (memq (cdr connection-type) '(nil pipe pty)))
+ (memq connection-type '(nil pipe pty)))
(signal 'wrong-type-argument (list #'symbolp connection-type)))
(unless (or (null filter) (eq filter t) (functionp filter))
(signal 'wrong-type-argument (list #'functionp filter)))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index dcc8c632f9..ae31287ece 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -4708,7 +4708,10 @@ substitution. SPEC-LIST is a list of char/value pairs
used for
(signal 'wrong-type-argument (list #'symbolp coding)))
(when (eq connection-type t)
(setq connection-type 'pty))
- (unless (memq connection-type '(nil pipe pty))
+ (unless (or (and (consp connection-type)
+ (memq (car connection-type) '(nil pipe pty))
+ (memq (cdr connection-type) '(nil pipe pty)))
+ (memq connection-type '(nil pipe pty)))
(signal 'wrong-type-argument (list #'symbolp connection-type)))
(unless (or (null filter) (eq filter t) (functionp filter))
(signal 'wrong-type-argument (list #'functionp filter)))
diff --git a/src/callproc.c b/src/callproc.c
index dd162f36a6..aec0a2f5a5 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -650,7 +650,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
child_errno
= emacs_spawn (&pid, filefd, fd_output, fd_error, new_argv, env,
- SSDATA (current_dir), NULL, &oldset);
+ SSDATA (current_dir), NULL, false, false, &oldset);
eassert ((child_errno == 0) == (0 < pid));
if (pid > 0)
@@ -1412,14 +1412,15 @@ emacs_posix_spawn_init_attributes (posix_spawnattr_t
*attributes,
int
emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err,
char **argv, char **envp, const char *cwd,
- const char *pty, const sigset_t *oldset)
+ const char *pty_name, bool pty_in, bool pty_out,
+ const sigset_t *oldset)
{
#if USABLE_POSIX_SPAWN
/* Prefer the simpler `posix_spawn' if available. `posix_spawn'
doesn't yet support setting up pseudoterminals, so we fall back
to `vfork' if we're supposed to use a pseudoterminal. */
- bool use_posix_spawn = pty == NULL;
+ bool use_posix_spawn = pty_name == NULL;
posix_spawn_file_actions_t actions;
posix_spawnattr_t attributes;
@@ -1473,7 +1474,9 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
/* vfork, and prevent local vars from being clobbered by the vfork. */
pid_t *volatile newpid_volatile = newpid;
const char *volatile cwd_volatile = cwd;
- const char *volatile pty_volatile = pty;
+ const char *volatile ptyname_volatile = pty_name;
+ bool volatile ptyin_volatile = pty_in;
+ bool volatile ptyout_volatile = pty_out;
char **volatile argv_volatile = argv;
int volatile stdin_volatile = std_in;
int volatile stdout_volatile = std_out;
@@ -1495,7 +1498,9 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
newpid = newpid_volatile;
cwd = cwd_volatile;
- pty = pty_volatile;
+ pty_name = ptyname_volatile;
+ pty_in = ptyin_volatile;
+ pty_out = ptyout_volatile;
argv = argv_volatile;
std_in = stdin_volatile;
std_out = stdout_volatile;
@@ -1506,13 +1511,12 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out,
int std_err,
if (pid == 0)
#endif /* not WINDOWSNT */
{
- bool pty_flag = pty != NULL;
/* Make the pty be the controlling terminal of the process. */
#ifdef HAVE_PTYS
dissociate_controlling_tty ();
/* Make the pty's terminal the controlling terminal. */
- if (pty_flag && std_in >= 0)
+ if (pty_in && std_in >= 0)
{
#ifdef TIOCSCTTY
/* We ignore the return value
@@ -1521,7 +1525,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
#endif
}
#if defined (LDISC1)
- if (pty_flag && std_in >= 0)
+ if (pty_in && std_in >= 0)
{
struct termios t;
tcgetattr (std_in, &t);
@@ -1531,7 +1535,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
}
#else
#if defined (NTTYDISC) && defined (TIOCSETD)
- if (pty_flag && std_in >= 0)
+ if (pty_in && std_in >= 0)
{
/* Use new line discipline. */
int ldisc = NTTYDISC;
@@ -1548,18 +1552,21 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out,
int std_err,
both TIOCSCTTY is defined. */
/* Now close the pty (if we had it open) and reopen it.
This makes the pty the controlling terminal of the subprocess. */
- if (pty_flag)
+ if (pty_name)
{
/* I wonder if emacs_close (emacs_open (pty, ...))
would work? */
- if (std_in >= 0)
+ if (pty_in && std_in >= 0)
emacs_close (std_in);
- std_out = std_in = emacs_open_noquit (pty, O_RDWR, 0);
-
+ int ptyfd = emacs_open_noquit (pty_name, O_RDWR, 0);
+ if (pty_in)
+ std_in = ptyfd;
+ if (pty_out)
+ std_out = ptyfd;
if (std_in < 0)
{
- emacs_perror (pty);
+ emacs_perror (pty_name);
_exit (EXIT_CANCELED);
}
@@ -1599,7 +1606,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
/* Stop blocking SIGCHLD in the child. */
unblock_child_signal (oldset);
- if (pty_flag)
+ if (pty_out)
child_setup_tty (std_out);
#endif
diff --git a/src/lisp.h b/src/lisp.h
index 8e36620fe5..fe6e98843d 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4943,7 +4943,8 @@ extern void setup_process_coding_systems (Lisp_Object);
#endif
extern int emacs_spawn (pid_t *, int, int, int, char **, char **,
- const char *, const char *, const sigset_t *);
+ const char *, const char *, bool, bool,
+ const sigset_t *);
extern char **make_environment_block (Lisp_Object) ATTRIBUTE_RETURNS_NONNULL;
extern void init_callproc_1 (void);
extern void init_callproc (void);
diff --git a/src/process.c b/src/process.c
index 1ac5a509e5..68dbd8b68b 100644
--- a/src/process.c
+++ b/src/process.c
@@ -1316,6 +1316,19 @@ set_process_filter_masks (struct Lisp_Process *p)
add_process_read_fd (p->infd);
}
+static bool
+is_pty_from_symbol (Lisp_Object symbol)
+{
+ if (EQ (symbol, Qpty))
+ return true;
+ else if (EQ (symbol, Qpipe))
+ return false;
+ else if (NILP (symbol))
+ return !NILP (Vprocess_connection_type);
+ else
+ report_file_error ("Unknown connection type", symbol);
+}
+
DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
2, 2, 0,
doc: /* Give PROCESS the filter function FILTER; nil means default.
@@ -1741,15 +1754,18 @@ signals to stop and continue a process.
:connection-type TYPE -- TYPE is control type of device used to
communicate with subprocesses. Values are `pipe' to use a pipe, `pty'
to use a pty, or nil to use the default specified through
-`process-connection-type'.
+`process-connection-type'. If TYPE is a cons (INPUT . OUTPUT), then
+INPUT will be used for standard input and OUTPUT for standard output
+(and standard error if `:stderr' is nil).
:filter FILTER -- Install FILTER as the process filter.
:sentinel SENTINEL -- Install SENTINEL as the process sentinel.
:stderr STDERR -- STDERR is either a buffer or a pipe process attached
-to the standard error of subprocess. Specifying this implies
-`:connection-type' is set to `pipe'. If STDERR is nil, standard error
+to the standard error of subprocess. When specifying this, the
+subprocess's standard error will always communicate via a pipe, no
+matter the value of `:connection-type'. If STDERR is nil, standard error
is mixed with standard output and sent to BUFFER or FILTER. (Note
that specifying :stderr will create a new, separate (but associated)
process, with its own filter and sentinel. See
@@ -1845,22 +1861,20 @@ usage: (make-process &rest ARGS) */)
CHECK_TYPE (NILP (tem), Qnull, tem);
tem = plist_get (contact, QCconnection_type);
- if (EQ (tem, Qpty))
- XPROCESS (proc)->pty_flag = true;
- else if (EQ (tem, Qpipe))
- XPROCESS (proc)->pty_flag = false;
- else if (NILP (tem))
- XPROCESS (proc)->pty_flag = !NILP (Vprocess_connection_type);
+ if (CONSP (tem))
+ {
+ XPROCESS (proc)->pty_in = is_pty_from_symbol (XCAR (tem));
+ XPROCESS (proc)->pty_out = is_pty_from_symbol (XCDR (tem));
+ }
else
- report_file_error ("Unknown connection type", tem);
-
- if (!NILP (stderrproc))
{
- pset_stderrproc (XPROCESS (proc), stderrproc);
-
- XPROCESS (proc)->pty_flag = false;
+ XPROCESS (proc)->pty_in = XPROCESS (proc)->pty_out =
+ is_pty_from_symbol (tem);
}
+ if (!NILP (stderrproc))
+ pset_stderrproc (XPROCESS (proc), stderrproc);
+
#ifdef HAVE_GNUTLS
/* AKA GNUTLS_INITSTAGE(proc). */
verify (GNUTLS_STAGE_EMPTY == 0);
@@ -2099,66 +2113,80 @@ static void
create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir)
{
struct Lisp_Process *p = XPROCESS (process);
- int inchannel, outchannel;
+ int inchannel = -1, outchannel = -1;
pid_t pid = -1;
int vfork_errno;
int forkin, forkout, forkerr = -1;
- bool pty_flag = 0;
+ bool pty_in = false, pty_out = false;
char pty_name[PTY_NAME_SIZE];
Lisp_Object lisp_pty_name = Qnil;
+ int ptychannel = -1, pty_tty = -1;
sigset_t oldset;
/* Ensure that the SIGCHLD handler can notify
`wait_reading_process_output'. */
child_signal_init ();
- inchannel = outchannel = -1;
-
- if (p->pty_flag)
- outchannel = inchannel = allocate_pty (pty_name);
+ if (p->pty_in || p->pty_out)
+ ptychannel = allocate_pty (pty_name);
- if (inchannel >= 0)
+ if (ptychannel >= 0)
{
- p->open_fd[READ_FROM_SUBPROCESS] = inchannel;
#if ! defined (USG) || defined (USG_SUBTTY_WORKS)
/* On most USG systems it does not work to open the pty's tty here,
then close it and reopen it in the child. */
/* Don't let this terminal become our controlling terminal
(in case we don't have one). */
- forkout = forkin = emacs_open (pty_name, O_RDWR | O_NOCTTY, 0);
- if (forkin < 0)
+ pty_tty = emacs_open (pty_name, O_RDWR | O_NOCTTY, 0);
+ if (pty_tty < 0)
report_file_error ("Opening pty", Qnil);
- p->open_fd[SUBPROCESS_STDIN] = forkin;
-#else
- forkin = forkout = -1;
#endif /* not USG, or USG_SUBTTY_WORKS */
- pty_flag = 1;
+ pty_in = p->pty_in;
+ pty_out = p->pty_out;
lisp_pty_name = build_string (pty_name);
}
+
+ /* Set up stdin for the child process. */
+ if (ptychannel >= 0 && p->pty_in)
+ {
+ p->open_fd[SUBPROCESS_STDIN] = forkin = pty_tty;
+ outchannel = ptychannel;
+ }
else
{
- if (emacs_pipe (p->open_fd + SUBPROCESS_STDIN) != 0
- || emacs_pipe (p->open_fd + READ_FROM_SUBPROCESS) != 0)
+ if (emacs_pipe (p->open_fd + SUBPROCESS_STDIN) != 0)
report_file_error ("Creating pipe", Qnil);
forkin = p->open_fd[SUBPROCESS_STDIN];
outchannel = p->open_fd[WRITE_TO_SUBPROCESS];
+ }
+
+ /* Set up stdout for the child process. */
+ if (ptychannel >= 0 && p->pty_out)
+ {
+ forkout = pty_tty;
+ p->open_fd[READ_FROM_SUBPROCESS] = inchannel = ptychannel;
+ }
+ else
+ {
+ if (emacs_pipe (p->open_fd + READ_FROM_SUBPROCESS) != 0)
+ report_file_error ("Creating pipe", Qnil);
inchannel = p->open_fd[READ_FROM_SUBPROCESS];
forkout = p->open_fd[SUBPROCESS_STDOUT];
#if defined(GNU_LINUX) && defined(F_SETPIPE_SZ)
fcntl (inchannel, F_SETPIPE_SZ, read_process_output_max);
#endif
+ }
- if (!NILP (p->stderrproc))
- {
- struct Lisp_Process *pp = XPROCESS (p->stderrproc);
+ if (!NILP (p->stderrproc))
+ {
+ struct Lisp_Process *pp = XPROCESS (p->stderrproc);
- forkerr = pp->open_fd[SUBPROCESS_STDOUT];
+ forkerr = pp->open_fd[SUBPROCESS_STDOUT];
- /* Close unnecessary file descriptors. */
- close_process_fd (&pp->open_fd[WRITE_TO_SUBPROCESS]);
- close_process_fd (&pp->open_fd[SUBPROCESS_STDIN]);
- }
+ /* Close unnecessary file descriptors. */
+ close_process_fd (&pp->open_fd[WRITE_TO_SUBPROCESS]);
+ close_process_fd (&pp->open_fd[SUBPROCESS_STDIN]);
}
if (FD_SETSIZE <= inchannel || FD_SETSIZE <= outchannel)
@@ -2183,7 +2211,8 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
we just reopen the device (see emacs_get_tty_pgrp) as this is
more portable (see USG_SUBTTY_WORKS above). */
- p->pty_flag = pty_flag;
+ p->pty_in = pty_in;
+ p->pty_out = pty_out;
pset_status (p, Qrun);
if (!EQ (p->command, Qt)
@@ -2199,13 +2228,15 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
block_input ();
block_child_signal (&oldset);
- pty_flag = p->pty_flag;
- eassert (pty_flag == ! NILP (lisp_pty_name));
+ pty_in = p->pty_in;
+ pty_out = p->pty_out;
+ eassert ((pty_in || pty_out) == ! NILP (lisp_pty_name));
vfork_errno
= emacs_spawn (&pid, forkin, forkout, forkerr, new_argv, env,
SSDATA (current_dir),
- pty_flag ? SSDATA (lisp_pty_name) : NULL, &oldset);
+ pty_in || pty_out ? SSDATA (lisp_pty_name) : NULL,
+ pty_in, pty_out, &oldset);
eassert ((vfork_errno == 0) == (0 < pid));
@@ -2263,7 +2294,7 @@ create_pty (Lisp_Object process)
{
struct Lisp_Process *p = XPROCESS (process);
char pty_name[PTY_NAME_SIZE];
- int pty_fd = !p->pty_flag ? -1 : allocate_pty (pty_name);
+ int pty_fd = !(p->pty_in || p->pty_out) ? -1 : allocate_pty (pty_name);
if (pty_fd >= 0)
{
@@ -2301,7 +2332,7 @@ create_pty (Lisp_Object process)
we just reopen the device (see emacs_get_tty_pgrp) as this is
more portable (see USG_SUBTTY_WORKS above). */
- p->pty_flag = 1;
+ p->pty_in = p->pty_out = true;
pset_status (p, Qrun);
setup_process_coding_systems (process);
@@ -2412,7 +2443,7 @@ usage: (make-pipe-process &rest ARGS) */)
p->kill_without_query = 1;
if (tem = plist_get (contact, QCstop), !NILP (tem))
pset_command (p, Qt);
- eassert (! p->pty_flag);
+ eassert (! p->pty_in && ! p->pty_out);
if (!EQ (p->command, Qt)
&& !EQ (p->filter, Qt))
@@ -3147,7 +3178,7 @@ usage: (make-serial-process &rest ARGS) */)
p->kill_without_query = 1;
if (tem = plist_get (contact, QCstop), !NILP (tem))
pset_command (p, Qt);
- eassert (! p->pty_flag);
+ eassert (! p->pty_in && ! p->pty_out);
if (!EQ (p->command, Qt)
&& !EQ (p->filter, Qt))
@@ -6808,7 +6839,7 @@ process_send_signal (Lisp_Object process, int signo,
Lisp_Object current_group,
error ("Process %s is not active",
SDATA (p->name));
- if (!p->pty_flag)
+ if (! p->pty_in)
current_group = Qnil;
/* If we are using pgrps, get a pgrp number and make it negative. */
@@ -7177,7 +7208,7 @@ process has been transmitted to the serial port. */)
send_process (proc, "", 0, Qnil);
}
- if (XPROCESS (proc)->pty_flag)
+ if (XPROCESS (proc)->pty_in)
send_process (proc, "\004", 1, Qnil);
else if (EQ (XPROCESS (proc)->type, Qserial))
{
diff --git a/src/process.h b/src/process.h
index 392b661ce6..92baf0c4cb 100644
--- a/src/process.h
+++ b/src/process.h
@@ -156,8 +156,9 @@ struct Lisp_Process
/* True means kill silently if Emacs is exited.
This is the inverse of the `query-on-exit' flag. */
bool_bf kill_without_query : 1;
- /* True if communicating through a pty. */
- bool_bf pty_flag : 1;
+ /* True if communicating through a pty for input or output. */
+ bool_bf pty_in : 1;
+ bool_bf pty_out : 1;
/* Flag to set coding-system of the process buffer from the
coding_system used to decode process output. */
bool_bf inherit_coding_system_flag : 1;
diff --git a/test/lisp/eshell/esh-proc-tests.el
b/test/lisp/eshell/esh-proc-tests.el
index 7f461d1813..734bb91a6a 100644
--- a/test/lisp/eshell/esh-proc-tests.el
+++ b/test/lisp/eshell/esh-proc-tests.el
@@ -28,6 +28,15 @@
(file-name-directory (or load-file-name
default-directory))))
+(defvar esh-proc-test--detect-pty-cmd
+ (concat "sh -c '"
+ "if [ -t 0 ]; then echo stdin; fi; "
+ "if [ -t 1 ]; then echo stdout; fi; "
+ "if [ -t 2 ]; then echo stderr; fi"
+ "'"))
+
+;;; Tests:
+
(ert-deftest esh-proc-test/sigpipe-exits-process ()
"Test that a SIGPIPE is properly sent to a process if a pipe closes"
(skip-unless (and (executable-find "sh")
@@ -44,6 +53,40 @@
(eshell-wait-for-subprocess t)
(should (eq (process-list) nil))))
+(ert-deftest esh-proc-test/pipeline-connection-type/no-pipeline ()
+ "Test that all streams are PTYs when a command is not in a pipeline."
+ (skip-unless (executable-find "sh"))
+ (should (equal (eshell-test-command-result esh-proc-test--detect-pty-cmd)
+ ;; PTYs aren't supported on MS-Windows.
+ (unless (eq system-type 'windows-nt)
+ "stdin\nstdout\nstderr\n"))))
+
+(ert-deftest esh-proc-test/pipeline-connection-type/first ()
+ "Test that only stdin is a PTY when a command starts a pipeline."
+ (skip-unless (and (executable-find "sh")
+ (executable-find "cat")))
+ (should (equal (eshell-test-command-result
+ (concat esh-proc-test--detect-pty-cmd " | cat"))
+ (unless (eq system-type 'windows-nt)
+ "stdin\n"))))
+
+(ert-deftest esh-proc-test/pipeline-connection-type/middle ()
+ "Test that all streams are pipes when a command is in the middle of a
+pipeline."
+ (skip-unless (and (executable-find "sh")
+ (executable-find "cat")))
+ (should (equal (eshell-test-command-result
+ (concat "echo | " esh-proc-test--detect-pty-cmd " | cat"))
+ nil)))
+
+(ert-deftest esh-proc-test/pipeline-connection-type/last ()
+ "Test that only output streams are PTYs when a command ends a pipeline."
+ (skip-unless (executable-find "sh"))
+ (should (equal (eshell-test-command-result
+ (concat "echo | " esh-proc-test--detect-pty-cmd))
+ (unless (eq system-type 'windows-nt)
+ "stdout\nstderr\n"))))
+
(ert-deftest esh-proc-test/kill-pipeline ()
"Test that killing a pipeline of processes only emits a single
prompt. See bug#54136."
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index aab95b2d73..b801563feb 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -38,10 +38,11 @@
;; Timeout in seconds; the test fails if the timeout is reached.
(defvar process-test-sentinel-wait-timeout 2.0)
-;; Start a process that exits immediately. Call WAIT-FUNCTION,
-;; possibly multiple times, to wait for the process to complete.
-(defun process-test-sentinel-wait-function-working-p (wait-function)
- (let ((proc (start-process "test" nil "bash" "-c" "exit 20"))
+(defun process-test-wait-for-sentinel (proc exit-status &optional
wait-function)
+ "Set a sentinel on PROC and wait for it to be called with EXIT-STATUS.
+Call WAIT-FUNCTION, possibly multiple times, to wait for the
+process to complete."
+ (let ((wait-function (or wait-function #'accept-process-output))
(sentinel-called nil)
(start-time (float-time)))
(set-process-sentinel proc (lambda (_proc _msg)
@@ -50,21 +51,22 @@
(> (- (float-time) start-time)
process-test-sentinel-wait-timeout)))
(funcall wait-function))
- (cl-assert (eq (process-status proc) 'exit))
- (cl-assert (= (process-exit-status proc) 20))
- sentinel-called))
+ (should sentinel-called)
+ (should (eq (process-status proc) 'exit))
+ (should (= (process-exit-status proc) exit-status))))
(ert-deftest process-test-sentinel-accept-process-output ()
(skip-unless (executable-find "bash"))
(with-timeout (60 (ert-fail "Test timed out"))
- (should (process-test-sentinel-wait-function-working-p
- #'accept-process-output))))
+ (let ((proc (start-process "test" nil "bash" "-c" "exit 20")))
+ (should (process-test-wait-for-sentinel proc 20)))))
(ert-deftest process-test-sentinel-sit-for ()
(skip-unless (executable-find "bash"))
(with-timeout (60 (ert-fail "Test timed out"))
- (should
- (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01
t))))))
+ (let ((proc (start-process "test" nil "bash" "-c" "exit 20")))
+ (should (process-test-wait-for-sentinel
+ proc 20 (lambda () (sit-for 0.01 t)))))))
(when (eq system-type 'windows-nt)
(ert-deftest process-test-quoted-batfile ()
@@ -97,17 +99,8 @@
"echo hello stderr! >&2; "
"exit 20"))
:buffer stdout-buffer
- :stderr stderr-buffer))
- (sentinel-called nil)
- (start-time (float-time)))
- (set-process-sentinel proc (lambda (_proc _msg)
- (setq sentinel-called t)))
- (while (not (or sentinel-called
- (> (- (float-time) start-time)
- process-test-sentinel-wait-timeout)))
- (accept-process-output))
- (cl-assert (eq (process-status proc) 'exit))
- (cl-assert (= (process-exit-status proc) 20))
+ :stderr stderr-buffer)))
+ (process-test-wait-for-sentinel proc 20)
(should (with-current-buffer stdout-buffer
(goto-char (point-min))
(looking-at "hello stdout!")))
@@ -118,8 +111,7 @@
(ert-deftest process-test-stderr-filter ()
(skip-unless (executable-find "bash"))
(with-timeout (60 (ert-fail "Test timed out"))
- (let* ((sentinel-called nil)
- (stderr-sentinel-called nil)
+ (let* ((stderr-sentinel-called nil)
(stdout-output nil)
(stderr-output nil)
(stdout-buffer (generate-new-buffer "*stdout*"))
@@ -131,23 +123,14 @@
(concat "echo hello stdout!; "
"echo hello stderr! >&2; "
"exit 20"))
- :stderr stderr-proc))
- (start-time (float-time)))
+ :stderr stderr-proc)))
(set-process-filter proc (lambda (_proc input)
(push input stdout-output)))
- (set-process-sentinel proc (lambda (_proc _msg)
- (setq sentinel-called t)))
(set-process-filter stderr-proc (lambda (_proc input)
(push input stderr-output)))
(set-process-sentinel stderr-proc (lambda (_proc _input)
(setq stderr-sentinel-called t)))
- (while (not (or sentinel-called
- (> (- (float-time) start-time)
- process-test-sentinel-wait-timeout)))
- (accept-process-output))
- (cl-assert (eq (process-status proc) 'exit))
- (cl-assert (= (process-exit-status proc) 20))
- (should sentinel-called)
+ (process-test-wait-for-sentinel proc 20)
(should (equal 1 (with-current-buffer stdout-buffer
(point-max))))
(should (equal "hello stdout!\n"
@@ -289,6 +272,74 @@
(error :got-error))))
(should have-called-debugger))))
+(defun make-process/test-connection-type (ttys &rest args)
+ "Make a process and check whether its standard streams match TTYS.
+This calls `make-process', passing ARGS to adjust how the process
+is created. TTYS should be a list of 3 boolean values,
+indicating whether the subprocess's stdin, stdout, and stderr
+should be a TTY, respectively."
+ (declare (indent 1))
+ (let* (;; MS-Windows doesn't support communicating via pty.
+ (ttys (if (eq system-type 'windows-nt) '(nil nil nil) ttys))
+ (expected-output (concat (and (nth 0 ttys) "stdin\n")
+ (and (nth 1 ttys) "stdout\n")
+ (and (nth 2 ttys) "stderr\n")))
+ (stdout-buffer (generate-new-buffer "*stdout*"))
+ (proc (apply
+ #'make-process
+ :name "test"
+ :command (list "sh" "-c"
+ (concat "if [ -t 0 ]; then echo stdin; fi; "
+ "if [ -t 1 ]; then echo stdout; fi; "
+ "if [ -t 2 ]; then echo stderr; fi"))
+ :buffer stdout-buffer
+ args)))
+ (process-test-wait-for-sentinel proc 0)
+ (should (equal (with-current-buffer stdout-buffer (buffer-string))
+ expected-output))))
+
+(ert-deftest make-process/connection-type/pty ()
+ (skip-unless (executable-find "sh"))
+ (make-process/test-connection-type '(t t t)
+ :connection-type 'pty))
+
+(ert-deftest make-process/connection-type/pty-2 ()
+ (skip-unless (executable-find "sh"))
+ (make-process/test-connection-type '(t t t)
+ :connection-type '(pty . pty)))
+
+(ert-deftest make-process/connection-type/pipe ()
+ (skip-unless (executable-find "sh"))
+ (make-process/test-connection-type '(nil nil nil)
+ :connection-type 'pipe))
+
+(ert-deftest make-process/connection-type/pipe-2 ()
+ (skip-unless (executable-find "sh"))
+ (make-process/test-connection-type '(nil nil nil)
+ :connection-type '(pipe . pipe)))
+
+(ert-deftest make-process/connection-type/in-pty ()
+ (skip-unless (executable-find "sh"))
+ (make-process/test-connection-type '(t nil nil)
+ :connection-type '(pty . pipe)))
+
+(ert-deftest make-process/connection-type/out-pty ()
+ (skip-unless (executable-find "sh"))
+ (make-process/test-connection-type '(nil t t)
+ :connection-type '(pipe . pty)))
+
+(ert-deftest make-process/connection-type/pty-with-stderr-buffer ()
+ (skip-unless (executable-find "sh"))
+ (let ((stderr-buffer (generate-new-buffer "*stderr*")))
+ (make-process/test-connection-type '(t t nil)
+ :connection-type 'pty :stderr stderr-buffer)))
+
+(ert-deftest make-process/connection-type/out-pty-with-stderr-buffer ()
+ (skip-unless (executable-find "sh"))
+ (let ((stderr-buffer (generate-new-buffer "*stderr*")))
+ (make-process/test-connection-type '(nil t nil)
+ :connection-type '(pipe . pty) :stderr stderr-buffer)))
+
(ert-deftest make-process/file-handler/found ()
"Check that the `:file-handler’ argument of `make-process’
works as expected if a file name handler is found."