master 2212b42806: Extend signal-process and proced.el

[Michael Albinus]

branch: master
commit 2212b42806757957fff6a9646debddecb301241c
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    Extend signal-process and proced.el
    
    * doc/lispref/processes.texi (Signals to Processes):
    Document changes in signal-process.
    
    * etc/NEWS: Mention changes in proced.el and signal-process.
    
    * lisp/proced.el (proced-signal-function): Declare it obsolete.
    (proced-remote-directory): New user option.
    (proced-mode): Adapt docstring.
    (proced-send-signal, proced-renice): Handle interactive prefix argument.
    
    * lisp/net/tramp.el (tramp-signal-process): New defun.  Add it to
    `signal-process-functions'.
    
    * src/process.c (Finternal_default_signal_process): New defun,
    providing the hitherto existing implementation of Fsignal_process.
    (Fsignal_process): Loop through Vsignal_process_functions.
    (Vsignal_process_functions): New defvar.
    (Qinternal_default_signal_process, Qsignal_process_functions):
    Declare symbols.
    (Sinternal_default_signal_process): Declare subroutine.
    
    * test/lisp/net/tramp-tests.el (tramp-test31-signal-process): New test.
---
 doc/lispref/processes.texi   | 23 +++++++++++++--
 etc/NEWS                     | 34 +++++++++++++++-------
 lisp/net/tramp.el            | 39 +++++++++++++++++++++++++
 lisp/proced.el               | 42 ++++++++++++++++++++-------
 src/process.c                | 44 ++++++++++++++++++++++------
 test/lisp/net/tramp-tests.el | 68 ++++++++++++++++++++++++++++++++++++++++++++
 6 files changed, 218 insertions(+), 32 deletions(-)

diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index ea51abda4b..ffc0f10a78 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -1472,7 +1472,7 @@ incoming data from the connection.  For serial 
connections, data that
 arrived during the time the process was stopped might be lost.
 @end defun
 
-@deffn Command signal-process process signal
+@deffn Command signal-process process signal &optional remote
 This function sends a signal to process @var{process}.  The argument
 @var{signal} specifies which signal to send; it should be an integer,
 or a symbol whose name is a signal.
@@ -1480,12 +1480,18 @@ or a symbol whose name is a signal.
 The @var{process} argument can be a system process @acronym{ID} (an
 integer); that allows you to send signals to processes that are not
 children of Emacs.  @xref{System Processes}.
+
+If @var{process} is a process object which contains the property
+@code{remote-pid}, or @var{process} is a number and @var{remote} is a
+remote file name, @var{process} is interpreted as process on the
+respective remote host, which will be the process to signal.
 @end deffn
 
 Sometimes, it is necessary to send a signal to a non-local
 asynchronous process.  This is possible by writing an own
-@code{interrupt-process} implementation.  This function must be added
-then to @code{interrupt-process-functions}.
+@code{interrupt-process} or @code{signal-process} implementation.
+This function must be added then to @code{interrupt-process-functions}
+or @code{signal-process-functions}, respectively.
 
 @defvar interrupt-process-functions
 This variable is a list of functions to be called for
@@ -1498,6 +1504,17 @@ default function, which shall always be the last in this 
list, is
 This is the mechanism, how Tramp implements @code{interrupt-process}.
 @end defvar
 
+@defvar signal-process-functions
+This variable is a list of functions to be called for
+@code{signal-process}.  The arguments of the functions are the same as
+for @code{signal-process}.  These functions are called in the order of
+the list, until one of them returns non-@code{nil}.  The default
+function, which shall always be the last in this list, is
+@code{signal-default-interrupt-process}.
+
+This is the mechanism, how Tramp implements @code{signal-process}.
+@end defvar
+
 @node Output from Processes
 @section Receiving Output from Processes
 @cindex process output
diff --git a/etc/NEWS b/etc/NEWS
index e684ee30f0..aaab0f4517 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -132,8 +132,8 @@ If you have code in your init file that removes directories 
from
 To get the previous action back, put something like the following in
 your init file:
 
-  (require 'ido)
-  (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head)
+    (require 'ido)
+    (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head)
 
 ---
 ** New user option 'term-clear-full-screen-programs'.
@@ -590,8 +590,8 @@ value.
 To enable this behavior, customize the user option
 'completion-auto-select' to t, then pressing 'TAB' will switch to the
 "*Completions*" buffer when it pops up that buffer.  If the value is
-'second-tab', then the first tab will display "*Completions*", and the
-second one will switch to the "*Completions*" buffer.
+'second-tab', then the first 'TAB' will display "*Completions*", and
+the second one will switch to the "*Completions*" buffer.
 
 *** New user option 'completion-wrap-movement'.
 When non-nil, the commands 'next-completion' and 'previous-completion'
@@ -710,8 +710,8 @@ It narrows to the current node.
 +++
 *** 'eudc-expansion-overwrites-query' to 'eudc-expansion-save-query-as-kill'.
 'eudc-expansion-overwrites-query' is renamed to
-'eudc-expansion-save-query-as-kill' to reflect the actual behaviour of
-the customization variable.
+'eudc-expansion-save-query-as-kill' to reflect the actual behavior of
+the user option.
 
 +++
 *** New command 'eudc-expand-try-all'.
@@ -722,10 +722,10 @@ return any.  This is useful for example, if one wants to 
search LDAP
 for a name that happens to match a contact in one's BBDB.
 
 +++
-*** New behaviour and default for option 'eudc-inline-expansion-format'
+*** New behavior and default for user option 'eudc-inline-expansion-format'.
 EUDC inline expansion result formatting defaulted to
 
-                 '("%s %s <%s>" firstname name email)
+    '("%s %s <%s>" firstname name email)
 
 Since email address specifications need to comply with RFC 5322 in
 order to be useful in messages, there was a risk to produce syntax
@@ -738,7 +738,7 @@ function.  In both cases, the formatted result will be in 
compliance
 with RFC 5322.  When set to nil, a default format very similar to the
 old default will be produced.  When set to a function, that function
 is called, and the returned values are used to populate the phrase and
-comment parts (see RFC 5322 for definitions). In both cases, the
+comment parts (see RFC 5322 for definitions).  In both cases, the
 phrase part will be automatically quoted if necessary.
 
 ** eww/shr
@@ -1153,13 +1153,20 @@ This library provides the 'autoarg-mode' and 
'autoarg-kp-mode' minor
 modes to emulate the behavior of the historical editor Twenex Emacs.
 It is believed to no longer be useful.
 
+---
+** proced.el supports sending signals to local processes with root permissions.
+When typing 'C-u k' or 'C-u r', sending a signal to or renicing of a
+local process will use alternative credentials.  The credentials to be
+used can be customised by the user option 'proced-remote-directory',
+which defaults to "/sudo::".  'proced-signal-function' has been marked 
obsolete.
+
 
 * New Modes and Packages in Emacs 29.1
 
 +++
 ** New package 'oclosure'.
 Allows the creation of "functions with slots" or "function objects"
-via the macros `oclosure-define` and `oclosure-lambda`.
+via the macros 'oclosure-define' and 'oclosure-lambda'.
 
 ---
 ** New theme 'leuven-dark'.
@@ -1814,6 +1821,13 @@ translation.
 This is useful when quoting shell arguments for a remote shell
 invocation.  Such shells are POSIX conform by default.
 
++++
+** 'signal-process' now consults the list 'signal-process-functions'.
+This is to determine which function has to be called in order to
+deliver the signal.  This allows Tramp to send the signal to remote
+asynchronous processes.  The hitherto existing implementation has been
+moved to 'signal-default-interrupt-process'.
+
 
 * Changes in Emacs 29.1 on Non-Free Operating Systems
 
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 4e5eed9d99..bddbe3f91a 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -5961,6 +5961,45 @@ name of a process or buffer, or nil to default to the 
current buffer."
  (lambda ()
    (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))
 
+(defun tramp-signal-process (process sigcode &optional remote)
+  "Send PROCESS the signal with code SIGCODE.
+PROCESS may also be a number specifying the process id of the
+process to signal; in this case, the process need not be a child of
+this Emacs.
+If PROCESS is a process object which contains the property
+`remote-pid', or PROCESS is a number and REMOTE is a remote file name,
+PROCESS is interpreted as process on the respective remote host, which
+will be the process to signal.
+SIGCODE may be an integer, or a symbol whose name is a signal name."
+  (let (pid vec)
+    (cond
+     ((processp process)
+      (setq pid (process-get process 'remote-pid)
+            vec (process-get process 'vector)))
+     ((numberp process)
+      (setq pid process
+            vec (and (stringp remote) (tramp-dissect-file-name remote))))
+     (t (signal 'wrong-type-argument (list #'processp process))))
+    (unless (or (numberp sigcode) (symbolp sigcode))
+      (signal 'wrong-type-argument (list #'numberp sigcode)))
+    ;; If it's a Tramp process, send SIGCODE remotely.
+    (when (and pid vec)
+      (tramp-message
+       vec 5 "Send signal %s to process %s with pid %s" sigcode process pid)
+      ;; This is for tramp-sh.el.  Other backends do not support this (yet).
+      (if (tramp-compat-funcall
+           'tramp-send-command-and-check
+           vec (format "\\kill -%s %d" sigcode pid))
+          0 -1))))
+
+;; `signal-process-functions' exists since Emacs 29.1.
+(when (boundp 'signal-process-functions)
+  (add-hook 'signal-process-functions #'tramp-signal-process)
+  (add-hook
+   'tramp-unload-hook
+   (lambda ()
+     (remove-hook 'signal-process-functions #'tramp-signal-process))))
+
 (defun tramp-get-remote-null-device (vec)
   "Return null device on the remote host identified by VEC.
 If VEC is `tramp-null-hop', return local null device."
diff --git a/lisp/proced.el b/lisp/proced.el
index c1d599afc4..7966ccfb08 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -29,10 +29,6 @@
 ;;
 ;; To do:
 ;; - Interactive temporary customizability of flags in `proced-grammar-alist'
-;; - Allow "sudo kill PID", "sudo renice PID"
-;;   `proced-send-signal' operates on multiple processes one by one.
-;;   With "sudo" we want to execute one "kill" or "renice" command
-;;   for all marked processes.  Is there a `sudo-call-process'?
 ;;
 ;; Thoughts and Ideas
 ;; - Currently, `process-attributes' returns the list of
@@ -61,6 +57,14 @@ It can be an elisp function (usually `signal-process') or a 
string specifying
 the external command (usually \"kill\")."
   :type '(choice (function :tag "function")
                  (string :tag "command")))
+(make-obsolete-variable 'proced-signal-function "no longer used." "29.1")
+
+(defcustom proced-remote-directory "/sudo::"
+  "Remote directory to be used when sending a signal.
+It must point to the local host, via a `sudo' or `doas' method,
+or alike.  See `proced-send-signal' and `proced-renice'."
+  :version "29.1"
+  :type '(string :tag "remote directory"))
 
 (defcustom proced-renice-command "renice"
   "Name of renice command."
@@ -626,6 +630,9 @@ Return nil if point is not on a process line."
 Type \\[proced] to start a Proced session.  In a Proced buffer
 type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
 Type \\[proced-send-signal] to send signals to marked processes.
+Type \\[proced-renice] to renice marked processes.
+With a prefix argument \\[universal-argument], sending signals to and renicing 
of processes
+will be performed with the credentials of `proced-remote-directory'.
 
 The initial content of a listing is defined by the variable `proced-filter'
 and the variable `proced-format'.
@@ -1766,7 +1773,10 @@ runs the normal hook `proced-after-send-signal-hook'.
 For backward compatibility SIGNAL and PROCESS-ALIST may be nil.
 Then PROCESS-ALIST contains the marked processes or the process point is on
 and SIGNAL is queried interactively.  This noninteractive usage is still
-supported but discouraged.  It will be removed in a future version of Emacs."
+supported but discouraged.  It will be removed in a future version of Emacs.
+
+With a prefix argument \\[universal-argument], send the signal with the 
credentials of
+`proced-remote-directory'."
   (interactive
    (let* ((process-alist (proced-marked-processes))
           (pnum (if (= 1 (length process-alist))
@@ -1808,7 +1818,10 @@ supported but discouraged.  It will be removed in a 
future version of Emacs."
                                         proced-signal-list
                                         nil nil nil nil "TERM"))))))
 
-  (let (failures)
+  (let ((default-directory
+         (if (and current-prefix-arg (stringp proced-remote-directory))
+             proced-remote-directory temporary-file-directory))
+        failures)
     ;; Why not always use `signal-process'?  See
     ;; https://lists.gnu.org/r/emacs-devel/2008-03/msg02955.html
     (if (functionp proced-signal-function)
@@ -1821,7 +1834,8 @@ supported but discouraged.  It will be removed in a 
future version of Emacs."
           (dolist (process process-alist)
             (condition-case err
                 (unless (zerop (funcall
-                                proced-signal-function (car process) signal))
+                                proced-signal-function (car process) signal
+                                (file-remote-p default-directory)))
                   (proced-log "%s\n" (cdr process))
                   (push (cdr process) failures))
               (error ; catch errors from failed signals
@@ -1833,7 +1847,7 @@ supported but discouraged.  It will be removed in a 
future version of Emacs."
         (dolist (process process-alist)
           (with-temp-buffer
             (condition-case nil
-                (unless (zerop (call-process
+                (unless (zerop (process-file
                                 proced-signal-function nil t nil
                                 signal (number-to-string (car process))))
                   (proced-log (current-buffer))
@@ -1862,7 +1876,10 @@ PROCESS-ALIST is an alist as returned by 
`proced-marked-processes'.
 Interactively, PROCESS-ALIST contains the marked processes.
 If no process is marked, it contains the process point is on,
 After renicing all processes in PROCESS-ALIST, this command runs
-the normal hook `proced-after-send-signal-hook'."
+the normal hook `proced-after-send-signal-hook'.
+
+With a prefix argument \\[universal-argument], apply renice with the 
credentials of
+`proced-remote-directory'."
   (interactive
    (let ((process-alist (proced-marked-processes)))
      (proced-with-processes-buffer process-alist
@@ -1871,11 +1888,14 @@ the normal hook `proced-after-send-signal-hook'."
    proced-mode)
   (if (numberp priority)
       (setq priority (number-to-string priority)))
-  (let (failures)
+  (let ((default-directory
+         (if (and current-prefix-arg (stringp proced-remote-directory))
+             proced-remote-directory temporary-file-directory))
+        failures)
     (dolist (process process-alist)
       (with-temp-buffer
         (condition-case nil
-            (unless (zerop (call-process
+            (unless (zerop (process-file
                             proced-renice-command nil t nil
                             priority (number-to-string (car process))))
               (proced-log (current-buffer))
diff --git a/src/process.c b/src/process.c
index 993e1c5603..e8aafd02d7 100644
--- a/src/process.c
+++ b/src/process.c
@@ -7034,14 +7034,13 @@ abbr_to_signal (char const *name)
   return -1;
 }
 
-DEFUN ("signal-process", Fsignal_process, Ssignal_process,
-       2, 2, "sProcess (name or number): \nnSignal code: ",
-       doc: /* Send PROCESS the signal with code SIGCODE.
-PROCESS may also be a number specifying the process id of the
-process to signal; in this case, the process need not be a child of
-this Emacs.
-SIGCODE may be an integer, or a symbol whose name is a signal name.  */)
-  (Lisp_Object process, Lisp_Object sigcode)
+DEFUN ("internal-default-signal-process",
+       Finternal_default_signal_process,
+       Sinternal_default_signal_process, 2, 3, 0,
+       doc: /* Default function to send PROCESS the signal with code SIGCODE.
+It shall be the last element in list `signal-process-functions'.
+See function `signal-process' for more details on usage.  */)
+  (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote)
 {
   pid_t pid;
   int signo;
@@ -7091,6 +7090,23 @@ SIGCODE may be an integer, or a symbol whose name is a 
signal name.  */)
   return make_fixnum (kill (pid, signo));
 }
 
+DEFUN ("signal-process", Fsignal_process, Ssignal_process,
+       2, 3, "sProcess (name or number): \nnSignal code: ",
+       doc: /* Send PROCESS the signal with code SIGCODE.
+PROCESS may also be a number specifying the process id of the
+process to signal; in this case, the process need not be a child of
+this Emacs.
+If PROCESS is a process object which contains the property
+`remote-pid', or PROCESS is a number and REMOTE is a remote file name,
+PROCESS is interpreted as process on the respective remote host, which
+will be the process to signal.
+SIGCODE may be an integer, or a symbol whose name is a signal name.  */)
+  (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote)
+{
+  return CALLN (Frun_hook_with_args_until_success, Qsignal_process_functions,
+               process, sigcode, remote);
+}
+
 DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0,
        doc: /* Make PROCESS see end-of-file in its input.
 EOF comes after any text already sent to it.
@@ -8580,6 +8596,13 @@ These functions are called in the order of the list, 
until one of them
 returns non-nil.  */);
   Vinterrupt_process_functions = list1 (Qinternal_default_interrupt_process);
 
+  DEFVAR_LISP ("signal-process-functions", Vsignal_process_functions,
+              doc: /* List of functions to be called for `signal-process'.
+The arguments of the functions are the same as for `signal-process'.
+These functions are called in the order of the list, until one of them
+returns non-nil.  */);
+  Vsignal_process_functions = list1 (Qinternal_default_signal_process);
+
   DEFVAR_LISP ("internal--daemon-sockname", Vinternal__daemon_sockname,
               doc: /* Name of external socket passed to Emacs, or nil if none. 
 */);
   Vinternal__daemon_sockname = Qnil;
@@ -8600,6 +8623,10 @@ sentinel or a process filter function has an error.  */);
          "internal-default-interrupt-process");
   DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions");
 
+  DEFSYM (Qinternal_default_signal_process,
+         "internal-default-signal-process");
+  DEFSYM (Qsignal_process_functions, "signal-process-functions");
+
   DEFSYM (Qnull, "null");
   DEFSYM (Qpipe_process_p, "pipe-process-p");
 
@@ -8654,6 +8681,7 @@ sentinel or a process filter function has an error.  */);
   defsubr (&Scontinue_process);
   defsubr (&Sprocess_running_child_p);
   defsubr (&Sprocess_send_eof);
+  defsubr (&Sinternal_default_signal_process);
   defsubr (&Ssignal_process);
   defsubr (&Swaiting_for_user_input_p);
   defsubr (&Sprocess_type);
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 94ff12bab4..c3b3f21d52 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -4984,6 +4984,7 @@ If UNSTABLE is non-nil, the test is tagged as 
`:unstable'."
 (ert-deftest tramp-test31-interrupt-process ()
   "Check `interrupt-process'."
   :tags (append '(:expensive-test :tramp-asynchronous-processes)
+                ;; The final `process-live-p' check does not run sufficiently.
                (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
                     '(:unstable)))
   (skip-unless (tramp--test-enabled))
@@ -5022,6 +5023,73 @@ If UNSTABLE is non-nil, the test is tagged as 
`:unstable'."
       ;; Cleanup.
       (ignore-errors (delete-process proc)))))
 
+(ert-deftest tramp-test31-signal-process ()
+  "Check `signal-process'."
+  :tags (append '(:expensive-test :tramp-asynchronous-processes)
+                ;; The final `process-live-p' check does not run sufficiently.
+               (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
+                    '(:unstable)))
+  (skip-unless (tramp--test-enabled))
+  (skip-unless (tramp--test-sh-p))
+  (skip-unless (not (tramp--test-crypt-p)))
+  ;; Since Emacs 29.1.
+  (skip-unless (boundp 'signal-process-functions))
+
+  ;; We must use `file-truename' for the temporary directory, in
+  ;; order to establish the connection prior running an asynchronous
+  ;; process.
+  (let ((default-directory (file-truename tramp-test-temporary-file-directory))
+       (delete-exited-processes t)
+       kill-buffer-query-functions command proc)
+
+    (dolist (sigcode '(2 INT))
+      (unwind-protect
+         (with-temp-buffer
+           (setq command "trap 'echo boom; exit 1' 2; sleep 100"
+                 proc (start-file-process-shell-command
+                       (format "test1%s" sigcode) (current-buffer) command))
+           (should (processp proc))
+           (should (process-live-p proc))
+           (should (equal (process-status proc) 'run))
+           (should (numberp (process-get proc 'remote-pid)))
+           (should (equal (process-get proc 'remote-command)
+                          (with-connection-local-variables
+                           `(,shell-file-name ,shell-command-switch 
,command))))
+           (should (zerop (signal-process proc sigcode)))
+           ;; Let the process accept the signal.
+           (with-timeout (10 (tramp--test-timeout-handler))
+             (while (accept-process-output proc 0 nil t)))
+            (should-not (process-live-p proc)))
+
+        ;; Cleanup.
+        (ignore-errors (kill-process proc))
+        (ignore-errors (delete-process proc)))
+
+      (unwind-protect
+         (with-temp-buffer
+           (setq command "trap 'echo boom; exit 1' 2; sleep 100"
+                 proc (start-file-process-shell-command
+                       (format "test2%s" sigcode) (current-buffer) command))
+           (should (processp proc))
+           (should (process-live-p proc))
+           (should (equal (process-status proc) 'run))
+           (should (numberp (process-get proc 'remote-pid)))
+           (should (equal (process-get proc 'remote-command)
+                          (with-connection-local-variables
+                           `(,shell-file-name ,shell-command-switch 
,command))))
+           (should
+             (zerop
+              (signal-process
+               (process-get proc 'remote-pid) sigcode default-directory)))
+           ;; Let the process accept the signal.
+           (with-timeout (10 (tramp--test-timeout-handler))
+             (while (accept-process-output proc 0 nil t)))
+            (should-not (process-live-p proc)))
+
+        ;; Cleanup.
+        (ignore-errors (kill-process proc))
+        (ignore-errors (delete-process proc))))))
+
 (defun tramp--test-async-shell-command
     (command output-buffer &optional error-buffer input)
   "Like `async-shell-command', reading the output.