From: Michael Albinus Date: Sun, 20 Aug 2017 19:18:05 +0000 (+0200) Subject: Implement `interrupt-process' for remote processes (Bug#28066) X-Git-Tag: emacs-26.0.90~396 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=296472f5c5db2b5c046af67f74dff2640e7127c2;p=emacs.git 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. --- 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]."