Commit bb1d42b9 authored by Michael Albinus's avatar Michael Albinus

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.
parent d3ead375
Pipeline #4729 passed with stage
in 55 minutes and 49 seconds
......@@ -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)))))))
......
......@@ -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 ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment