master bd07d4fac9: Improve Tramp's process-file implementations

[Michael Albinus]

branch: master
commit bd07d4fac9da40cecf6a5936fd4b4c8ebb751586
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    Improve Tramp's process-file implementations
    
    * lisp/net/tramp-adb.el (tramp-adb-handle-process-file)
    * lisp/net/tramp-sh.el (tramp-sh-handle-process-file):
    * lisp/net/tramp-smb.el (tramp-smb-handle-process-file):
    * lisp/net/tramp-sshfs.el (tramp-sshfs-handle-process-file):
    Improve implementation.  (Bug#53854)
    
    * test/lisp/net/tramp-tests.el (tramp-test28-process-file)
    (tramp--test-check-files, tramp-test47-unload): Extend tests.
---
 lisp/net/tramp-adb.el        |   6 +--
 lisp/net/tramp-sh.el         |   4 +-
 lisp/net/tramp-smb.el        |   2 +-
 lisp/net/tramp-sshfs.el      |  55 +++++++++++++++++--
 test/lisp/net/tramp-tests.el | 126 ++++++++++++++++++++++++++++++++-----------
 5 files changed, 153 insertions(+), 40 deletions(-)

diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 85cd2d9bc1..c683f4c6e8 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -818,7 +818,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are 
completely ignored."
        (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
        (if (tramp-equal-remote default-directory infile)
            ;; INFILE is on the same remote host.
-           (setq input (tramp-file-local-name infile))
+           (setq input (tramp-unquote-file-local-name infile))
          ;; INFILE must be copied to remote host.
          (setq input (tramp-make-tramp-temp-file v)
                tmpinput (tramp-make-tramp-file-name v input))
@@ -849,7 +849,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are 
completely ignored."
          (setcar (cdr destination) (expand-file-name (cadr destination)))
          (if (tramp-equal-remote default-directory (cadr destination))
              ;; stderr is on the same remote host.
-             (setq stderr (tramp-file-local-name (cadr destination)))
+             (setq stderr (tramp-unquote-file-local-name (cadr destination)))
            ;; stderr must be copied to remote host.  The temporary
            ;; file must be deleted after execution.
            (setq stderr (tramp-make-tramp-temp-file v)
@@ -1264,7 +1264,7 @@ connection if a previous connection has died for some 
reason."
        (if (zerop (length device))
            (tramp-error vec 'file-error "Device %s not connected" host))
        (with-tramp-progress-reporter vec 3 "Opening adb shell connection"
-         (let* ((coding-system-for-read 'utf-8-dos) ;is this correct?
+         (let* ((coding-system-for-read 'utf-8-dos)  ; Is this correct?
                 (process-connection-type tramp-process-connection-type)
                 (args (if (> (length host) 0)
                           (list "-s" device "shell")
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index ea089224ae..40ddf106c9 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -3118,7 +3118,7 @@ implementation will be used."
        (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
        (if (tramp-equal-remote default-directory infile)
            ;; INFILE is on the same remote host.
-           (setq input (tramp-file-local-name infile))
+           (setq input (tramp-unquote-file-local-name infile))
          ;; INFILE must be copied to remote host.
          (setq input (tramp-make-tramp-temp-file v)
                tmpinput (tramp-make-tramp-file-name v input))
@@ -3149,7 +3149,7 @@ implementation will be used."
          (setcar (cdr destination) (expand-file-name (cadr destination)))
          (if (tramp-equal-remote default-directory (cadr destination))
              ;; stderr is on the same remote host.
-             (setq stderr (tramp-file-local-name (cadr destination)))
+             (setq stderr (tramp-unquote-file-local-name (cadr destination)))
            ;; stderr must be copied to remote host.  The temporary
            ;; file must be deleted after execution.
            (setq stderr (tramp-make-tramp-temp-file v)
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 6515519680..f52fa0a93b 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -1284,7 +1284,7 @@ component is used as the target of the symlink."
        (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
        (if (tramp-equal-remote default-directory infile)
            ;; INFILE is on the same remote host.
-           (setq input (tramp-file-local-name infile))
+           (setq input (tramp-unquote-file-local-name infile))
          ;; INFILE must be copied to remote host.
          (setq input (tramp-make-tramp-temp-file v)
                tmpinput (tramp-make-tramp-file-name v input))
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 664dbc31b1..3f23b1a878 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -240,12 +240,13 @@ arguments to pass to the OPERATION."
     (error "Implementation does not handle immediate return"))
 
   (with-parsed-tramp-file-name (expand-file-name default-directory) nil
-    (let ((command
+    (let ((coding-system-for-read 'utf-8-dos)  ; Is this correct?
+         (command
           (format
            "cd %s && exec %s"
            (tramp-unquote-shell-quote-argument localname)
            (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))
-         input tmpinput)
+         input tmpinput stderr tmpstderr outbuf)
 
       ;; Determine input.
       (if (null infile)
@@ -253,18 +254,55 @@ arguments to pass to the OPERATION."
        (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
        (if (tramp-equal-remote default-directory infile)
            ;; INFILE is on the same remote host.
-           (setq input (tramp-file-local-name infile))
+           (setq input (tramp-unquote-file-local-name infile))
          ;; INFILE must be copied to remote host.
          (setq input (tramp-make-tramp-temp-file v)
                tmpinput (tramp-make-tramp-file-name v input))
          (copy-file infile tmpinput t)))
       (when input (setq command (format "%s <%s" command input)))
 
+      ;; Determine output.
+      (cond
+       ;; Just a buffer.
+       ((bufferp destination)
+       (setq outbuf destination))
+       ;; A buffer name.
+       ((stringp destination)
+       (setq outbuf (get-buffer-create destination)))
+       ;; (REAL-DESTINATION ERROR-DESTINATION)
+       ((consp destination)
+       ;; output.
+       (cond
+        ((bufferp (car destination))
+         (setq outbuf (car destination)))
+        ((stringp (car destination))
+         (setq outbuf (get-buffer-create (car destination))))
+        ((car destination)
+         (setq outbuf (current-buffer))))
+       ;; stderr.
+       (cond
+        ((stringp (cadr destination))
+         (setcar (cdr destination) (expand-file-name (cadr destination)))
+         (if (tramp-equal-remote default-directory (cadr destination))
+             ;; stderr is on the same remote host.
+             (setq stderr (tramp-unquote-file-local-name (cadr destination)))
+           ;; stderr must be copied to remote host.  The temporary
+           ;; file must be deleted after execution.
+           (setq stderr (tramp-make-tramp-temp-file v)
+                 tmpstderr (tramp-make-tramp-file-name v stderr))))
+        ;; stderr to be discarded.
+        ((null (cadr destination))
+         (setq stderr (tramp-get-remote-null-device v)))))
+       ;; 't
+       (destination
+       (setq outbuf (current-buffer))))
+      (when stderr (setq command (format "%s 2>%s" command stderr)))
+
       (unwind-protect
          (apply
           #'tramp-call-process
           v (tramp-get-method-parameter v 'tramp-login-program)
-          nil destination display
+          nil outbuf display
           (tramp-expand-args
            v 'tramp-login-args
            ?h (or (tramp-file-name-host v) "")
@@ -272,6 +310,15 @@ arguments to pass to the OPERATION."
            ?p (or (tramp-file-name-port v) "")
            ?l command))
 
+       ;; Synchronize stderr.
+       (when tmpstderr
+         (tramp-cleanup-connection v 'keep-debug 'keep-password)
+         (tramp-fuse-unmount v))
+
+       ;; Provide error file.
+       (when tmpstderr
+         (rename-file tmpstderr (cadr destination) t))
+
        ;; Cleanup.  We remove all file cache values for the
        ;; connection, because the remote process could have changed
        ;; them.
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index d78e8815b2..baddcd2d7a 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -4398,6 +4398,7 @@ This tests also `make-symbolic-link', `file-truename' and 
`add-name-to-file'."
     (let* ((tmp-name (tramp--test-make-temp-name nil quoted))
           (fnnd (file-name-nondirectory tmp-name))
           (default-directory tramp-test-temporary-file-directory)
+          (buffer (get-buffer-create "*tramp-tests*"))
           kill-buffer-query-functions)
       (unwind-protect
          (progn
@@ -4430,31 +4431,47 @@ This tests also `make-symbolic-link', `file-truename' 
and `add-name-to-file'."
                   (tramp--test-shell-file-name)
                   nil nil nil "-c" "kill -2 $$")))))
 
-           (with-temp-buffer
-             (write-region "foo" nil tmp-name)
-             (should (file-exists-p tmp-name))
-             (should (zerop (process-file "ls" nil t nil fnnd)))
-             ;; "ls" could produce colorized output.
-             (goto-char (point-min))
-             (while
-                 (re-search-forward tramp-display-escape-sequence-regexp nil t)
-               (replace-match "" nil nil))
-             (should (string-equal (format "%s\n" fnnd) (buffer-string)))
-             (should-not (get-buffer-window (current-buffer) t))
+           ;; Check DESTINATION.
+           (dolist (destination `(nil t ,buffer))
+             (when (bufferp destination)
+               (with-current-buffer destination
+                 (delete-region (point-min) (point-max))))
+             (with-temp-buffer
+               (write-region "foo" nil tmp-name)
+               (should (file-exists-p tmp-name))
+               (should (zerop (process-file "ls" nil destination nil fnnd)))
+               (with-current-buffer
+                   (if (bufferp destination) destination (current-buffer))
+                 ;; "ls" could produce colorized output.
+                 (goto-char (point-min))
+                 (while (re-search-forward
+                         tramp-display-escape-sequence-regexp nil t)
+                   (replace-match "" nil nil))
+                 (should
+                  (string-equal (if destination (format "%s\n" fnnd) "")
+                                (buffer-string)))
+                 (should-not (get-buffer-window (current-buffer) t))
+                 (goto-char (point-max)))
+
+               ;; Second run.  The output must be appended.
+               (should (zerop (process-file "ls" nil destination t fnnd)))
+               (with-current-buffer
+                   (if (bufferp destination) destination (current-buffer))
+                 ;; "ls" could produce colorized output.
+                 (goto-char (point-min))
+                 (while (re-search-forward
+                         tramp-display-escape-sequence-regexp nil t)
+                   (replace-match "" nil nil))
+                 (should
+                  (string-equal
+                   (if destination (format "%s\n%s\n" fnnd fnnd) "")
+                   (buffer-string))))
 
-             ;; Second run.  The output must be appended.
-             (goto-char (point-max))
-             (should (zerop (process-file "ls" nil t t fnnd)))
-             ;; "ls" could produce colorized output.
-             (goto-char (point-min))
-             (while
-                 (re-search-forward tramp-display-escape-sequence-regexp nil t)
-               (replace-match "" nil nil))
-             (should
-              (string-equal (format "%s\n%s\n" fnnd fnnd) (buffer-string)))
-             ;; A non-nil DISPLAY must not raise the buffer.
-             (should-not (get-buffer-window (current-buffer) t))
-             (delete-file tmp-name))
+               (unless (eq destination t)
+                 (should (string-empty-p (buffer-string))))
+               ;; A non-nil DISPLAY must not raise the buffer.
+               (should-not (get-buffer-window (current-buffer) t))
+               (delete-file tmp-name)))
 
            ;; Check remote and local INFILE.
            (dolist (local '(nil t))
@@ -4464,10 +4481,37 @@ This tests also `make-symbolic-link', `file-truename' 
and `add-name-to-file'."
                (should (file-exists-p tmp-name))
                (should (zerop (process-file "cat" tmp-name t)))
                (should (string-equal "foo" (buffer-string)))
-               (should-not (get-buffer-window (current-buffer) t)))
-             (delete-file tmp-name)))
+               (should-not (get-buffer-window (current-buffer) t))
+               (delete-file tmp-name)))
+
+           ;; Check remote and local DESTNATION file.  This isn't
+           ;; implemented yet ina all file name handler backends.
+           ;; (dolist (local '(nil t))
+           ;;   (setq tmp-name (tramp--test-make-temp-name local quoted))
+           ;;   (should
+           ;;    (zerop (process-file "echo" nil `(:file ,tmp-name) nil 
"foo")))
+           ;;   (with-temp-buffer
+           ;;  (insert-file-contents tmp-name)
+           ;;  (should (string-equal "foo" (buffer-string)))
+           ;;  (should-not (get-buffer-window (current-buffer) t))
+           ;;  (delete-file tmp-name)))
+
+           ;; Check remote and local STDERR.
+           (dolist (local '(nil t))
+             (setq tmp-name (tramp--test-make-temp-name local quoted))
+             (should-not
+              (zerop
+               (process-file "cat" nil `(t ,tmp-name) nil "/does-not-exist")))
+             (with-temp-buffer
+               (insert-file-contents tmp-name)
+               (should
+                (string-match-p
+                 "cat:.* No such file or directory" (buffer-string)))
+               (should-not (get-buffer-window (current-buffer) t))
+               (delete-file tmp-name))))
 
        ;; Cleanup.
+       (ignore-errors (kill-buffer buffer))
        (ignore-errors (delete-file tmp-name))))))
 
 ;; Must be a command, because used as `sigusr1' handler.
@@ -6479,7 +6523,13 @@ This requires restrictions of file name syntax."
                ;; `default-directory' with special characters.  See
                ;; Bug#53846.
                (when (and (tramp--test-expensive-test-p)
-                          (tramp--test-supports-processes-p))
+                          (tramp--test-supports-processes-p)
+                          ;; Prior Emacs 27, `shell-file-name' was
+                          ;; hard coded as "/bin/sh" for remote
+                          ;; processes in Emacs.  That doesn't work
+                          ;; for tramp-adb.el.
+                          (or (not (tramp--test-adb-p))
+                              (tramp--test-emacs27-p)))
                  (let ((default-directory file1))
                    (dolist (this-shell-command
                             (append
@@ -7207,17 +7257,20 @@ Since it unloads Tramp, it shall be the last test to 
run."
   (should (featurep 'tramp-archive))
   ;; This unloads also tramp-archive.el and tramp-theme.el if needed.
   (unload-feature 'tramp 'force)
-  ;; No Tramp feature must be left.
+
+  ;; No Tramp feature must be left except the test packages.
   (should-not (featurep 'tramp))
   (should-not (featurep 'tramp-archive))
   (should-not (featurep 'tramp-theme))
   (should-not
    (all-completions
     "tramp" (delq 'tramp-tests (delq 'tramp-archive-tests features))))
+
   ;; `file-name-handler-alist' must be clean.
   (should-not (all-completions "tramp" (mapcar #'cdr file-name-handler-alist)))
+
   ;; There shouldn't be left a bound symbol, except buffer-local
-  ;; variables, and autoload functions.  We do not regard our test
+  ;; variables, and autoloaded functions.  We do not regard our test
   ;; symbols, and the Tramp unload hooks.
   (mapatoms
    (lambda (x)
@@ -7231,6 +7284,7 @@ Since it unloads Tramp, it shall be the last test to run."
          (not (string-match-p "unload-hook$" (symbol-name x)))
          (not (get x 'tramp-autoload))
          (ert-fail (format "`%s' still bound" x)))))
+
   ;; The defstruct `tramp-file-name' and all its internal functions
   ;; shall be purged.
   (should-not (cl--find-class 'tramp-file-name))
@@ -7239,6 +7293,7 @@ Since it unloads Tramp, it shall be the last test to run."
      (and (functionp x)
           (string-match-p "tramp-file-name" (symbol-name x))
           (ert-fail (format "Structure function `%s' still exists" x)))))
+
   ;; There shouldn't be left a hook function containing a Tramp
   ;; function.  We do not regard the Tramp unload hooks.
   (mapatoms
@@ -7248,7 +7303,18 @@ Since it unloads Tramp, it shall be the last test to 
run."
          (not (string-match-p "unload-hook$" (symbol-name x)))
          (consp (symbol-value x))
          (ignore-errors (all-completions "tramp" (symbol-value x)))
-         (ert-fail (format "Hook `%s' still contains Tramp function" x))))))
+         (ert-fail (format "Hook `%s' still contains Tramp function" x)))))
+
+  ;; There shouldn't be left an advice function from Tramp.
+  (mapatoms
+   (lambda (x)
+     (and (functionp x)
+         (advice-mapc
+          (lambda (fun _symbol)
+            (and (string-match-p "^tramp" (symbol-name fun))
+                 (ert-fail
+                  (format "Function `%s' still contains Tramp advice" x))))
+          x)))))
 
 (defun tramp-test-all (&optional interactive)
   "Run all tests for \\[tramp].