mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-04-27 16:51:06 -07:00
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.
This commit is contained in:
Michael Albinus
parent
cf74c27ba1
commit
296472f5c5
3 changed files with 97 additions and 41 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]."
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue