[Emacs-diffs] master 296472f: Implement `interrupt-process' for remote processes (Bug#28066)

[Michael Albinus]

branch: master
commit 296472f5c5db2b5c046af67f74dff2640e7127c2
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>

    Implement `interrupt-process' for remote processes (Bug#28066)
    
    * lisp/net/tramp-sh.el (tramp-sh-handle-start-file-process):
    Support sending signals remotely.
    (tramp-open-connection-setup-interactive-shell):
    Trace "remote-tty" connection property.
    
    * lisp/net/tramp.el (tramp-advice-interrupt-process): New defun.
    (top): Add advice to `interrupt-process'.  (Bug#28066)
    
    * test/lisp/net/tramp-tests.el (tramp-test28-interrupt-process):
    New test.
    (tramp-test29-shell-command)
    (tramp-test30-environment-variables)
    (tramp-test30-environment-variables-and-port-numbers)
    (tramp-test31-explicit-shell-file-name)
    (tramp-test32-vc-registered)
    (tramp-test33-make-auto-save-file-name)
    (tramp-test34-make-nearby-temp-file)
    (tramp-test35-special-characters)
    (tramp-test35-special-characters-with-stat)
    (tramp-test35-special-characters-with-perl)
    (tramp-test35-special-characters-with-ls, tramp-test36-utf8)
    (tramp-test36-utf8-with-stat, tramp-test36-utf8-with-perl)
    (tramp-test36-utf8-with-ls)
    (tramp-test37-asynchronous-requests)
    (tramp-test38-recursive-load, tramp-test39-remote-load-path)
    (tramp-test40-unload): Rename.
    (tramp-test40-unload): Test also removal of advice.
---
 lisp/net/tramp-sh.el         | 39 +++++++++++++------------
 lisp/net/tramp.el            | 31 ++++++++++++++++++++
 test/lisp/net/tramp-tests.el | 68 +++++++++++++++++++++++++++++---------------
 3 files changed, 97 insertions(+), 41 deletions(-)

diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 6b365c1..50b3801 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -2875,7 +2875,8 @@ the result will be a local, non-Tramp, file name."
           ;; We do not want to raise an error when
           ;; `start-file-process' has been started several times in
           ;; `eshell' and friends.
-          (tramp-current-connection nil))
+          (tramp-current-connection nil)
+          p)
 
       (while (get-process name1)
        ;; NAME must be unique as process name.
@@ -2905,33 +2906,37 @@ the result will be a local, non-Tramp, file name."
                  ;; to cleanup the prompt afterwards.
                  (catch 'suppress
                    (tramp-maybe-open-connection v)
+                   (setq p (tramp-get-connection-process v))
+                   ;; Set the pid of the remote shell.  This is
+                   ;; needed when sending signals remotely.
+                   (let ((pid (tramp-send-command-and-read v "echo $$")))
+                     (process-put p 'remote-pid pid)
+                     (tramp-set-connection-property p "remote-pid" pid))
                    (widen)
-                   (delete-region mark (point))
+                   (delete-region mark (point-max))
                    (narrow-to-region (point-max) (point-max))
                    ;; Now do it.
                    (if command
                        ;; Send the command.
                        (tramp-send-command v command nil t) ; nooutput
                      ;; Check, whether a pty is associated.
-                     (unless (process-get
-                              (tramp-get-connection-process v) 'remote-tty)
+                     (unless (process-get p 'remote-tty)
                        (tramp-error
                         v 'file-error
                         "pty association is not supported for `%s'" name))))
-                 (let ((p (tramp-get-connection-process v)))
-                   ;; Set query flag and process marker for this
-                   ;; process.  We ignore errors, because the process
-                   ;; could have finished already.
-                   (ignore-errors
-                     (set-process-query-on-exit-flag p t)
-                     (set-marker (process-mark p) (point)))
-                   ;; Return process.
-                   p))))
+                 ;; Set query flag and process marker for this
+                 ;; process.  We ignore errors, because the process
+                 ;; could have finished already.
+                 (ignore-errors
+                   (set-process-query-on-exit-flag p t)
+                   (set-marker (process-mark p) (point)))
+                 ;; Return process.
+                 p)))
 
          ;; Save exit.
          (if (string-match tramp-temp-buffer-name (buffer-name))
              (ignore-errors
-               (set-process-buffer (tramp-get-connection-process v) nil)
+               (set-process-buffer p nil)
                (kill-buffer (current-buffer)))
            (set-buffer-modified-p bmp))
          (tramp-set-connection-property v "process-name" nil)
@@ -4111,7 +4116,8 @@ process to set up.  VEC specifies the connection."
     ;; Set `remote-tty' process property.
     (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\"" 
'noerror)))
       (unless (zerop (length tty))
-       (process-put proc 'remote-tty tty)))
+       (process-put proc 'remote-tty tty)
+       (tramp-set-connection-property proc "remote-tty" tty)))
 
     ;; Dump stty settings in the traces.
     (when (>= tramp-verbose 9)
@@ -5687,9 +5693,6 @@ function cell is returned to be applied on a buffer."
 ;; * Reconnect directly to a compliant shell without first going
 ;;   through the user's default shell.  (Pete Forman)
 ;;
-;; * How can I interrupt the remote process with a signal
-;;   (interrupt-process seems not to work)?  (Markus Triska)
-;;
 ;; * Avoid the local shell entirely for starting remote processes.  If
 ;;   so, I think even a signal, when delivered directly to the local
 ;;   SSH instance, would correctly be propagated to the remote process
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 8d7fbc0..3469d45 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -4378,6 +4378,37 @@ Only works for Bourne-like shells."
                                      t t result)))
        result))))
 
+;;; Signal handling.  This works for remote processes, which have set
+;;; the process property `remote-pid'.
+
+(defun tramp-advice-interrupt-process (orig-fun &rest args)
+  "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)
+    ;; 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)))
+
 ;;; Integration of eshell.el:
 
 ;; eshell.el keeps the path in `eshell-path-env'.  We must change it
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 9dc276b..dba553a 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2900,7 +2900,26 @@ This tests also `make-symbolic-link', `file-truename' 
and `add-name-to-file'."
        ;; Cleanup.
        (ignore-errors (delete-process proc))))))
 
-(ert-deftest tramp-test28-shell-command ()
+(ert-deftest tramp-test28-interrupt-process ()
+  "Check `interrupt-process'."
+  :tags '(:expensive-test)
+  (skip-unless (tramp--test-enabled))
+  (skip-unless (tramp--test-sh-p))
+
+  (let ((default-directory tramp-test-temporary-file-directory)
+       kill-buffer-query-functions proc)
+    (unwind-protect
+       (with-temp-buffer
+         (setq proc (start-file-process "test" (current-buffer) "sleep" "10"))
+         (should (processp proc))
+         (should (equal (process-status proc) 'run))
+         (interrupt-process proc)
+         (should (equal (process-status proc) 'signal)))
+
+      ;; Cleanup.
+      (ignore-errors (delete-process proc)))))
+
+(ert-deftest tramp-test29-shell-command ()
   "Check `shell-command'."
   :tags '(:expensive-test)
   (skip-unless (tramp--test-enabled))
@@ -3004,7 +3023,7 @@ This tests also `make-symbolic-link', `file-truename' and 
`add-name-to-file'."
     (buffer-substring-no-properties (point-min) (point-max))))
 
 ;; This test is inspired by Bug#23952.
-(ert-deftest tramp-test29-environment-variables ()
+(ert-deftest tramp-test30-environment-variables ()
   "Check that remote processes set / unset environment variables properly."
   :tags '(:expensive-test)
   (skip-unless (tramp--test-enabled))
@@ -3082,7 +3101,7 @@ This tests also `make-symbolic-link', `file-truename' and 
`add-name-to-file'."
                (funcall this-shell-command-to-string "set")))))))))
 
 ;; This test is inspired by Bug#27009.
-(ert-deftest tramp-test29-environment-variables-and-port-numbers ()
+(ert-deftest tramp-test30-environment-variables-and-port-numbers ()
   "Check that two connections with separate ports are different."
   (skip-unless (tramp--test-enabled))
   ;; We test it only for the mock-up connection; otherwise there might
@@ -3121,7 +3140,7 @@ This tests also `make-symbolic-link', `file-truename' and 
`add-name-to-file'."
       (tramp-cleanup-connection (tramp-dissect-file-name dir)))))
 
 ;; The functions were introduced in Emacs 26.1.
-(ert-deftest tramp-test30-explicit-shell-file-name ()
+(ert-deftest tramp-test31-explicit-shell-file-name ()
   "Check that connection-local `explicit-shell-file-name' is set."
   :tags '(:expensive-test)
   (skip-unless (tramp--test-enabled))
@@ -3165,7 +3184,7 @@ This tests also `make-symbolic-link', `file-truename' and 
`add-name-to-file'."
       (put 'explicit-shell-file-name 'permanent-local nil)
       (kill-buffer "*shell*"))))
 
-(ert-deftest tramp-test31-vc-registered ()
+(ert-deftest tramp-test32-vc-registered ()
   "Check `vc-registered'."
   :tags '(:expensive-test)
   (skip-unless (tramp--test-enabled))
@@ -3238,7 +3257,7 @@ This tests also `make-symbolic-link', `file-truename' and 
`add-name-to-file'."
        ;; Cleanup.
        (ignore-errors (delete-directory tmp-name1 'recursive))))))
 
-(ert-deftest tramp-test32-make-auto-save-file-name ()
+(ert-deftest tramp-test33-make-auto-save-file-name ()
   "Check `make-auto-save-file-name'."
   (skip-unless (tramp--test-enabled))
 
@@ -3333,7 +3352,7 @@ This tests also `make-symbolic-link', `file-truename' and 
`add-name-to-file'."
        (ignore-errors (delete-directory tmp-name2 'recursive))))))
 
 ;; The functions were introduced in Emacs 26.1.
-(ert-deftest tramp-test33-make-nearby-temp-file ()
+(ert-deftest tramp-test34-make-nearby-temp-file ()
   "Check `make-nearby-temp-file' and `temporary-file-directory'."
   (skip-unless (tramp--test-enabled))
   ;; Since Emacs 26.1.
@@ -3600,7 +3619,7 @@ This requires restrictions of file name syntax."
        (ignore-errors (delete-directory tmp-name2 'recursive))))))
 
 (defun tramp--test-special-characters ()
-  "Perform the test in `tramp-test34-special-characters*'."
+  "Perform the test in `tramp-test35-special-characters*'."
   ;; Newlines, slashes and backslashes in file names are not
   ;; supported.  So we don't test.  And we don't test the tab
   ;; character on Windows or Cygwin, because the backslash is
@@ -3643,7 +3662,7 @@ This requires restrictions of file name syntax."
    "{foo}bar{baz}"))
 
 ;; These tests are inspired by Bug#17238.
-(ert-deftest tramp-test34-special-characters ()
+(ert-deftest tramp-test35-special-characters ()
   "Check special characters in file names."
   (skip-unless (tramp--test-enabled))
   (skip-unless (not (tramp--test-rsync-p)))
@@ -3651,7 +3670,7 @@ This requires restrictions of file name syntax."
 
   (tramp--test-special-characters))
 
-(ert-deftest tramp-test34-special-characters-with-stat ()
+(ert-deftest tramp-test35-special-characters-with-stat ()
   "Check special characters in file names.
 Use the `stat' command."
   :tags '(:expensive-test)
@@ -3669,7 +3688,7 @@ Use the `stat' command."
          tramp-connection-properties)))
     (tramp--test-special-characters)))
 
-(ert-deftest tramp-test34-special-characters-with-perl ()
+(ert-deftest tramp-test35-special-characters-with-perl ()
   "Check special characters in file names.
 Use the `perl' command."
   :tags '(:expensive-test)
@@ -3690,7 +3709,7 @@ Use the `perl' command."
          tramp-connection-properties)))
     (tramp--test-special-characters)))
 
-(ert-deftest tramp-test34-special-characters-with-ls ()
+(ert-deftest tramp-test35-special-characters-with-ls ()
   "Check special characters in file names.
 Use the `ls' command."
   :tags '(:expensive-test)
@@ -3713,7 +3732,7 @@ Use the `ls' command."
     (tramp--test-special-characters)))
 
 (defun tramp--test-utf8 ()
-  "Perform the test in `tramp-test35-utf8*'."
+  "Perform the test in `tramp-test36-utf8*'."
   (let* ((utf8 (if (and (eq system-type 'darwin)
                        (memq 'utf-8-hfs (coding-system-list)))
                   'utf-8-hfs 'utf-8))
@@ -3728,7 +3747,7 @@ Use the `ls' command."
      "银河系漫游指南系列"
      "Автостопом по гала́ктике")))
 
-(ert-deftest tramp-test35-utf8 ()
+(ert-deftest tramp-test36-utf8 ()
   "Check UTF8 encoding in file names and file contents."
   (skip-unless (tramp--test-enabled))
   (skip-unless (not (tramp--test-docker-p)))
@@ -3738,7 +3757,7 @@ Use the `ls' command."
 
   (tramp--test-utf8))
 
-(ert-deftest tramp-test35-utf8-with-stat ()
+(ert-deftest tramp-test36-utf8-with-stat ()
   "Check UTF8 encoding in file names and file contents.
 Use the `stat' command."
   :tags '(:expensive-test)
@@ -3758,7 +3777,7 @@ Use the `stat' command."
          tramp-connection-properties)))
     (tramp--test-utf8)))
 
-(ert-deftest tramp-test35-utf8-with-perl ()
+(ert-deftest tramp-test36-utf8-with-perl ()
   "Check UTF8 encoding in file names and file contents.
 Use the `perl' command."
   :tags '(:expensive-test)
@@ -3781,7 +3800,7 @@ Use the `perl' command."
          tramp-connection-properties)))
     (tramp--test-utf8)))
 
-(ert-deftest tramp-test35-utf8-with-ls ()
+(ert-deftest tramp-test36-utf8-with-ls ()
   "Check UTF8 encoding in file names and file contents.
 Use the `ls' command."
   :tags '(:expensive-test)
@@ -3809,7 +3828,7 @@ Use the `ls' command."
   (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test)))))
 
 ;; This test is inspired by Bug#16928.
-(ert-deftest tramp-test36-asynchronous-requests ()
+(ert-deftest tramp-test37-asynchronous-requests ()
   "Check parallel asynchronous requests.
 Such requests could arrive from timers, process filters and
 process sentinels.  They shall not disturb each other."
@@ -3966,7 +3985,7 @@ process sentinels.  They shall not disturb each other."
         (ignore-errors (cancel-timer timer))
         (ignore-errors (delete-directory tmp-name 'recursive)))))))
 
-(ert-deftest tramp-test37-recursive-load ()
+(ert-deftest tramp-test38-recursive-load ()
   "Check that Tramp does not fail due to recursive load."
   (skip-unless (tramp--test-enabled))
 
@@ -3989,7 +4008,7 @@ process sentinels.  They shall not disturb each other."
          (mapconcat 'shell-quote-argument load-path " -L ")
          (shell-quote-argument code))))))))
 
-(ert-deftest tramp-test38-remote-load-path ()
+(ert-deftest tramp-test39-remote-load-path ()
   "Check that Tramp autoloads its packages with remote `load-path'."
   ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el.
   ;; It shall still work, when a remote file name is in the
@@ -4012,7 +4031,7 @@ process sentinels.  They shall not disturb each other."
        (mapconcat 'shell-quote-argument load-path " -L ")
        (shell-quote-argument code)))))))
 
-(ert-deftest tramp-test39-unload ()
+(ert-deftest tramp-test40-unload ()
   "Check that Tramp and its subpackages unload completely.
 Since it unloads Tramp, it shall be the last test to run."
   :tags '(:expensive-test)
@@ -4053,7 +4072,10 @@ 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)))))))
+           (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))))
 
 ;; TODO:
 
@@ -4070,7 +4092,7 @@ Since it unloads Tramp, it shall be the last test to run."
 ;; * Fix `tramp-test05-expand-file-name-relative' in `expand-file-name'.
 ;; * Fix `tramp-test06-directory-file-name' for `ftp'.
 ;; * Fix `tramp-test27-start-file-process' on MS Windows (`process-send-eof'?).
-;; * Fix Bug#16928 in `tramp-test36-asynchronous-requests'.
+;; * Fix Bug#16928 in `tramp-test37-asynchronous-requests'.
 
 (defun tramp-test-all (&optional interactive)
   "Run all tests for \\[tramp]."