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.

2 files changed, 159 insertions, 55 deletions

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 ()