master bb1d42b: Implement `shell-command-dont-erase-buffer' in Tramp. (Bug#39067)

[Michael Albinus]

branch: master
commit bb1d42b955629487537dee9423d5a4fc837033ae
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>

    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.
---
 lisp/net/tramp.el            |  73 +++++++++++++---------
 test/lisp/net/tramp-tests.el | 141 +++++++++++++++++++++++++++++++++++--------
 2 files changed, 159 insertions(+), 55 deletions(-)

diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 70d0fb0..a38b3c6 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 7ffd22e..89ab493 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 ()