From: Michael Albinus Date: Sat, 1 Feb 2020 13:29:45 +0000 (+0100) Subject: Implement `shell-command-dont-erase-buffer' in Tramp. (Bug#39067) X-Git-Tag: emacs-28.0.90~7908^2~25 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=bb1d42b955629487537dee9423d5a4fc837033ae;p=emacs.git Implement `shell-command-dont-erase-buffer' in Tramp. (Bug#39067) * lisp/net/tramp.el (tramp-handle-shell-command): Handle `shell-command-dont-erase-buffer'. (Bug#39067) * test/lisp/net/tramp-tests.el (shell-command-dont-erase-buffer): Declare. (tramp-test10-write-region, tramp-test21-file-links): Use function symbols. (tramp--test-async-shell-command): Don't assume that `async-shell-command' returns the process object. (tramp-test32-shell-command): Rework `async-shell-command-width' test. (tramp-test32-shell-command-dont-erase-buffer): New test. --- diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 70d0fb070d8..a38b3c6e51c 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3621,8 +3621,13 @@ support symbolic links." (output-buffer-p output-buffer) (output-buffer (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) + ((bufferp output-buffer) + (setq current-buffer-p (eq (current-buffer) output-buffer)) + output-buffer) + ((stringp output-buffer) + (setq current-buffer-p + (eq (buffer-name (current-buffer)) output-buffer)) + (get-buffer-create output-buffer)) (output-buffer (setq current-buffer-p t) (current-buffer)) @@ -3634,6 +3639,11 @@ support symbolic links." (cond ((bufferp error-buffer) error-buffer) ((stringp error-buffer) (get-buffer-create error-buffer)))) + (error-file + (and error-buffer + (with-parsed-tramp-file-name default-directory nil + (tramp-make-tramp-file-name + v (tramp-make-tramp-temp-file v))))) (bname (buffer-name output-buffer)) (p (get-buffer-process output-buffer)) (dir default-directory) @@ -3641,7 +3651,7 @@ support symbolic links." ;; The following code is taken from `shell-command', slightly ;; adapted. Shouldn't it be factored out? - (when p + (when (and (integerp asynchronous) p) (cond ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. @@ -3677,22 +3687,21 @@ support symbolic links." (with-current-buffer output-buffer (setq default-directory dir))) - (setq buffer (if error-buffer - (with-parsed-tramp-file-name default-directory nil - (list output-buffer - (tramp-make-tramp-file-name - v (tramp-make-tramp-temp-file v)))) - output-buffer)) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) - (with-current-buffer output-buffer + (setq buffer (if error-file (list output-buffer error-file) output-buffer)) + + (with-current-buffer output-buffer + (when current-buffer-p + (barf-if-buffer-read-only) + (push-mark nil t)) + ;; `shell-command-save-pos-or-erase' has been introduced with + ;; Emacs 27.1. + (if (fboundp 'shell-command-save-pos-or-erase) + (tramp-compat-funcall + 'shell-command-save-pos-or-erase current-buffer-p) (setq buffer-read-only nil) (erase-buffer))) - (if (and (not current-buffer-p) (integerp asynchronous)) + (if (integerp asynchronous) (let ((tramp-remote-process-environment ;; `async-shell-command-width' has been introduced with ;; Emacs 27.1. @@ -3706,9 +3715,9 @@ support symbolic links." (setq p (start-file-process-shell-command (buffer-name output-buffer) buffer command)) ;; Insert error messages if they were separated. - (when (consp buffer) + (when error-file (with-current-buffer error-buffer - (insert-file-contents-literally (cadr buffer)))) + (insert-file-contents-literally error-file))) (if (process-live-p p) ;; Display output. (with-current-buffer output-buffer @@ -3717,34 +3726,40 @@ support symbolic links." (shell-mode) (set-process-filter p #'comint-output-filter) (set-process-sentinel p #'shell-command-sentinel) - (when (consp buffer) + (when error-file (add-function :after (process-sentinel p) (lambda (_proc _string) (with-current-buffer error-buffer (insert-file-contents-literally - (cadr buffer) nil nil nil 'replace)) - (delete-file (cadr buffer)))))) + error-file nil nil nil 'replace)) + (delete-file error-file))))) - (when (consp buffer) - (delete-file (cadr buffer)))))) + (when error-file + (delete-file error-file))))) (prog1 ;; Run the process. (process-file-shell-command command nil buffer nil) ;; Insert error messages if they were separated. - (when (consp buffer) + (when error-file (with-current-buffer error-buffer - (insert-file-contents-literally (cadr buffer))) - (delete-file (cadr buffer))) + (insert-file-contents-literally error-file)) + (delete-file error-file)) (if current-buffer-p ;; This is like exchange-point-and-mark, but doesn't ;; activate the mark. It is cleaner to avoid activation, ;; even though the command loop would deactivate the mark ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) + (progn + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) + (current-buffer)))) + ;; `shell-command-set-point-after-cmd' has been + ;; introduced with Emacs 27.1. + (if (fboundp 'shell-command-set-point-after-cmd) + (tramp-compat-funcall + 'shell-command-set-point-after-cmd))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 7ffd22e77be..89ab493c062 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -72,6 +72,8 @@ (defvar connection-local-profile-alist) ;; Needed for Emacs 26. (defvar async-shell-command-width) +;; Needed for Emacs 27. +(defvar shell-command-dont-erase-buffer) ;; Beautify batch mode. (when noninteractive @@ -2389,14 +2391,14 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t)) + (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) ;; Ange-FTP. ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) (should-error - (cl-letf (((symbol-function 'y-or-n-p) 'ignore) + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) ;; Ange-FTP. ((symbol-function 'yes-or-no-p) 'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) @@ -3416,11 +3418,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3492,11 +3494,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) @@ -4437,7 +4439,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (command output-buffer &optional error-buffer input) "Like `async-shell-command', reading the output. INPUT, if non-nil, is a string sent to the process." - (let ((proc (async-shell-command command output-buffer error-buffer)) + (async-shell-command command output-buffer error-buffer) + (let ((proc (get-buffer-process output-buffer)) (delete-exited-processes t)) (when (stringp input) (process-send-string proc input)) @@ -4532,25 +4535,111 @@ INPUT, if non-nil, is a string sent to the process." (buffer-string)))) ;; Cleanup. - (ignore-errors (delete-file tmp-name))) - - ;; Test `async-shell-command-width'. Since Emacs 27.1. - (when (ignore-errors - (and (boundp 'async-shell-command-width) - (zerop (call-process "tput" nil nil nil "cols")) - (zerop (process-file "tput" nil nil nil "cols")))) - (let (async-shell-command-width) - (should - (string-equal - (format "%s\n" (car (process-lines "tput" "cols"))) - (tramp--test-shell-command-to-string-asynchronously - "tput cols"))) - (setq async-shell-command-width 1024) - (should - (string-equal - "1024\n" - (tramp--test-shell-command-to-string-asynchronously - "tput cols")))))))) + (ignore-errors (delete-file tmp-name))))) + + ;; Test `async-shell-command-width'. It exists since Emacs 26.1, + ;; but seems to work since Emacs 27.1 only. + (when (and (tramp--test-sh-p) (tramp--test-emacs27-p)) + (let* ((async-shell-command-width 1024) + (cols (ignore-errors + (read (tramp--test-shell-command-to-string-asynchronously + "tput cols"))))) + (when (natnump cols) + (should (= cols async-shell-command-width)))))) + +(ert-deftest tramp-test32-shell-command-dont-erase-buffer () + "Check `shell-command'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. + (skip-unless (tramp--test-emacs27-p)) + + ;; We check both the local and remote case, in order to guarantee + ;; that they behave similar. + (dolist (default-directory + `(,temporary-file-directory ,tramp-test-temporary-file-directory)) + (let ((buffer (generate-new-buffer "foo")) + ;; Suppress nasty messages. + (inhibit-message t) + point kill-buffer-query-functions) + (unwind-protect + (progn + ;; Don't erase if buffer is the current one. Point is not moved. + (let (shell-command-dont-erase-buffer) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + (should (= point (point))))) + + ;; Erase if the buffer is not current one. + (let (shell-command-dont-erase-buffer) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "baz\n" (buffer-string))) + (should (= point (point))))) + + ;; Erase if buffer is the current one, but + ;; `shell-command-dont-erase-buffer' is set to `erase'. + (let ((shell-command-dont-erase-buffer 'erase)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "baz\n" (buffer-string))) + (should (= (point) (point-max))))) + + ;; Don't erase if `shell-command-dont-erase-buffer' is set + ;; to `beg-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'beg-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + (should (= point (point))))) + + ;; Don't erase if `shell-command-dont-erase-buffer' is set + ;; to `end-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'end-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + (should (= (point) (point-max))))) + + ;; Don't erase if `shell-command-dont-erase-buffer' is set + ;; to `save-point'. Check point. + (let ((shell-command-dont-erase-buffer 'save-point)) + (with-temp-buffer + (insert "bar") + (goto-char (1- (point-max))) + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (1- (point-max)))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + (should (= point (point)))))) + + ;; Cleanup. + (ignore-errors (kill-buffer buffer)))))) ;; This test is inspired by Bug#23952. (ert-deftest tramp-test33-environment-variables ()