From 296472f5c5db2b5c046af67f74dff2640e7127c2 Mon Sep 17 00:00:00 2001
From: Michael Albinus <michael.albinus@gmx.de>
Date: Sun, 20 Aug 2017 21:18:05 +0200
Subject: [PATCH] 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 6b365c10e25..50b380100ba 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 8d7fbc068b8..3469d45ff2a 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 9dc276b2a93..dba553a2c5e 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]."
-- 
2.39.2