[Emacs-diffs] master 01844e4: Implement `interrupt-process-functions'

[Michael Albinus]

branch: master
commit 01844e40dc43baf1fdc088ef6400343e908ea449
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>

    Implement `interrupt-process-functions'
    
    * lisp/net/tramp.el (tramp-interrupt-process): Rename from
    `tramp-advice-interrupt-process'.  Adapt according to changed API.
    (top): Add it to `interrupt-process-functions'.
    
    * src/process.c (Finternal_default_interrupt_process): New defun.
    (Finterrupt_process): Change implementation, based on
    Vinterrupt_process_functions.
    (Vinterrupt_process_functions): New defvar.
    
    * test/lisp/net/tramp-tests.el (tramp-test40-unload): Do not
    test removal of advice.
---
 lisp/net/tramp.el            | 53 +++++++++++++++++++++++---------------------
 src/process.c                | 33 ++++++++++++++++++++++++---
 test/lisp/net/tramp-tests.el |  5 +----
 3 files changed, 59 insertions(+), 32 deletions(-)

diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 3469d45..2aa9a6b 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -4381,33 +4381,36 @@ Only works for Bourne-like shells."
 ;;; Signal handling.  This works for remote processes, which have set
 ;;; the process property `remote-pid'.
 
-(defun tramp-advice-interrupt-process (orig-fun &rest args)
+(defun tramp-interrupt-process (&optional process _current-group)
   "Interrupt remote process PROC."
-  (let* ((arg0 (car args))
-        (proc (cond
-               ((processp arg0) arg0)
-               ((bufferp arg0)  (get-buffer-process arg0))
-               ((stringp arg0)  (or (get-process arg0)
-                                    (get-buffer-process arg0)))
-               ((null arg0)     (get-buffer-process (current-buffer)))
-               (t               arg0)))
-        pid)
+  ;; CURRENT-GROUP is not implemented yet.
+  (let ((proc (cond
+              ((processp process) process)
+              ((bufferp process)  (get-buffer-process process))
+              ((stringp process)  (or (get-process process)
+                                      (get-buffer-process process)))
+              ((null process)     (get-buffer-process (current-buffer)))
+              (t                  process)))
+       pid)
     ;; If it's a Tramp process, send the INT signal remotely.
-    (if (and (processp proc)
-            (setq pid (process-get proc 'remote-pid)))
-       (progn
-         (tramp-message proc 5 "%s %s" proc pid)
-         (tramp-send-command
-          (tramp-get-connection-property proc "vector" nil)
-          (format "kill -2 %d" pid)))
-      ;; Otherwise, just run the original function.
-      (apply orig-fun args))))
-
-(advice-add 'interrupt-process :around 'tramp-advice-interrupt-process)
-(add-hook
- 'tramp-unload-hook
- (lambda ()
-   (advice-remove 'interrupt-process 'tramp-advice-interrupt-process)))
+    (when (and (processp proc)
+              (setq pid (process-get proc 'remote-pid)))
+      (tramp-message proc 5 "Interrupt process %s with pid %s" proc pid)
+      ;; This is for tramp-sh.el.  Other backends do not support this (yet).
+      (tramp-compat-funcall
+       'tramp-send-command
+       (tramp-get-connection-property proc "vector" nil)
+       (format "kill -2 %d" pid))
+      ;; Report success.
+      proc)))
+
+;; `interrupt-process-functions' exists since Emacs 26.1.
+(when (boundp 'interrupt-process-functions)
+  (add-hook 'interrupt-process-functions 'tramp-interrupt-process)
+  (add-hook
+   'tramp-unload-hook
+   (lambda ()
+     (remove-hook 'interrupt-process-functions 'tramp-interrupt-process))))
 
 ;;; Integration of eshell.el:
 
diff --git a/src/process.c b/src/process.c
index 1900951..e7ee99a 100644
--- a/src/process.c
+++ b/src/process.c
@@ -6677,6 +6677,18 @@ process_send_signal (Lisp_Object process, int signo, 
Lisp_Object current_group,
   unblock_child_signal (&oldset);
 }
 
+DEFUN ("internal-default-interrupt-process",
+       Finternal_default_interrupt_process,
+       Sinternal_default_interrupt_process, 0, 2, 0,
+       doc: /* Default function to interrupt process PROCESS.
+It shall be the last element in list `interrupt-process-functions'.
+See function `interrupt-process' for more details on usage.  */)
+  (Lisp_Object process, Lisp_Object current_group)
+{
+  process_send_signal (process, SIGINT, current_group, 0);
+  return process;
+}
+
 DEFUN ("interrupt-process", Finterrupt_process, Sinterrupt_process, 0, 2, 0,
        doc: /* Interrupt process PROCESS.
 PROCESS may be a process, a buffer, or the name of a process or buffer.
@@ -6688,11 +6700,14 @@ If the process is a shell, this means interrupt current 
subjob
 rather than the shell.
 
 If CURRENT-GROUP is `lambda', and if the shell owns the terminal,
-don't send the signal.  */)
+don't send the signal.
+
+This function calls the functions of `interrupt-process-functions' in
+the order of the list, until one of them returns non-`nil'.  */)
   (Lisp_Object process, Lisp_Object current_group)
 {
-  process_send_signal (process, SIGINT, current_group, 0);
-  return process;
+  return CALLN (Frun_hook_with_args_until_success, 
Qinterrupt_process_functions,
+               process, current_group);
 }
 
 DEFUN ("kill-process", Fkill_process, Skill_process, 0, 2, 0,
@@ -8176,6 +8191,17 @@ non-nil value means that the delay is not reset on write.
 The variable takes effect when `start-process' is called.  */);
   Vprocess_adaptive_read_buffering = Qt;
 
+  DEFVAR_LISP ("interrupt-process-functions", Vinterrupt_process_functions,
+              doc: /* List of functions to be called for `interrupt-function'.
+The arguments of the functions are the same as for `interrupt-function'.
+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);
+
+  DEFSYM (Qinternal_default_interrupt_process,
+         "internal-default-interrupt-process");
+  DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions");
+
   defsubr (&Sprocessp);
   defsubr (&Sget_process);
   defsubr (&Sdelete_process);
@@ -8218,6 +8244,7 @@ The variable takes effect when `start-process' is called. 
 */);
   defsubr (&Saccept_process_output);
   defsubr (&Sprocess_send_region);
   defsubr (&Sprocess_send_string);
+  defsubr (&Sinternal_default_interrupt_process);
   defsubr (&Sinterrupt_process);
   defsubr (&Skill_process);
   defsubr (&Squit_process);
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index dba553a..129bc1d 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -4072,10 +4072,7 @@ Since it unloads Tramp, it shall be the last test to 
run."
            (not (string-match "unload-hook$" (symbol-name x)))
            (consp (symbol-value x))
            (ignore-errors (all-completions "tramp" (symbol-value x)))
-           (ert-fail (format "Hook `%s' still contains Tramp function" x)))))
-    ;; The advice on `interrupt-process' shall be removed.
-    (should-not
-     (advice-member-p 'tramp-advice-interrupt-process 'interrupt-process))))
+           (ert-fail (format "Hook `%s' still contains Tramp function" x)))))))
 
 ;; TODO: