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.
This commit is contained in:
Michael Albinus
parent
d3ead37509
commit
bb1d42b955
2 changed files with 157 additions and 53 deletions
|
|
@ -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))
|
||||
(setq buffer (if error-file (list output-buffer error-file) output-buffer))
|
||||
|
||||
(if current-buffer-p
|
||||
(progn
|
||||
(barf-if-buffer-read-only)
|
||||
(push-mark nil t))
|
||||
(with-current-buffer 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)))))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
(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"))))))))
|
||||
;; 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 ()
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue