[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 296472f: Implement `interrupt-process' for remote p
From: |
Michael Albinus |
Subject: |
[Emacs-diffs] master 296472f: Implement `interrupt-process' for remote processes (Bug#28066) |
Date: |
Sun, 20 Aug 2017 15:18:21 -0400 (EDT) |
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]."
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 296472f: Implement `interrupt-process' for remote processes (Bug#28066),
Michael Albinus <=