From 01844e40dc43baf1fdc088ef6400343e908ea449 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 21 Aug 2017 17:30:33 +0200 Subject: [PATCH] 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 3469d45ff2a..2aa9a6b9859 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 19009515336..e7ee99ab3d9 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 dba553a2c5e..129bc1d65da 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: -- 2.39.2