; Tramp: fixes resulting from test campaign

* lisp/net/tramp-gvfs.el (tramp-gvfs-do-copy-or-rename-file):
Handle symlinks.

* lisp/net/tramp-sshfs.el (tramp-sshfs-handle-process-file):
STDERR is not implemented.

* lisp/net/tramp.el (tramp-skeleton-process-file): Raise a warning
if STDERR is not implemented.
(tramp-handle-shell-command):
Respect `async-shell-command-display-buffer'.

* test/lisp/net/tramp-tests.el (tramp-test28-process-file): Adapt test.

(cherry picked from commit f6632114fe661930c45b5e9c1bf66644be095ff9)

diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 45b8e53de3b06fb17e66cb86ea87184e8a63e7f1..0ea9f4bb66c45df85cf9b3106db0abcb89a59b2d 100644 (file)
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -1051,100 +1051,106 @@ file names."
       (progn
        (copy-directory filename newname keep-date t)
        (when (eq op 'rename) (delete-directory filename 'recursive)))
+    (if (file-symlink-p filename)
+       (progn
+         (make-symbolic-link
+          (file-symlink-p filename) newname ok-if-already-exists)
+         (when (eq op 'rename) (delete-file filename)))
+
+      (let ((t1 (tramp-tramp-file-p filename))
+           (t2 (tramp-tramp-file-p newname))
+           (equal-remote (tramp-equal-remote filename newname))
+           (volatile
+            (and (eq op 'rename) (tramp-gvfs-file-name-p filename)
+                 (equal
+                  (cdr
+                   (assoc
+                    "standard::is-volatile"
+                    (tramp-gvfs-get-file-attributes filename)))
+                  "TRUE")))
+           ;; "gvfs-rename" is not trustworthy.
+           (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move"))
+           (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+
+       (with-parsed-tramp-file-name (if t1 filename newname) nil
+         (tramp-barf-if-file-missing v filename
+           (when (and (not ok-if-already-exists) (file-exists-p newname))
+             (tramp-error v 'file-already-exists newname))
+           (when (and (file-directory-p newname)
+                      (not (directory-name-p newname)))
+             (tramp-error v 'file-error "File is a directory %s" newname))
+           (when (file-regular-p newname)
+             (delete-file newname))
 
-    (let ((t1 (tramp-tramp-file-p filename))
-         (t2 (tramp-tramp-file-p newname))
-         (equal-remote (tramp-equal-remote filename newname))
-         (volatile
-          (and (eq op 'rename) (tramp-gvfs-file-name-p filename)
-               (equal
-                (cdr
-                 (assoc
-                  "standard::is-volatile"
-                  (tramp-gvfs-get-file-attributes filename)))
-                "TRUE")))
-         ;; "gvfs-rename" is not trustworthy.
-         (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move"))
-         (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
-
-      (with-parsed-tramp-file-name (if t1 filename newname) nil
-       (tramp-barf-if-file-missing v filename
-         (when (and (not ok-if-already-exists) (file-exists-p newname))
-           (tramp-error v 'file-already-exists newname))
-         (when (and (file-directory-p newname)
-                    (not (directory-name-p newname)))
-           (tramp-error v 'file-error "File is a directory %s" newname))
-         (when (file-regular-p newname)
-           (delete-file newname))
-
-         (cond
-          ;; We cannot rename volatile files, as used by Google-drive.
-          ((and (not equal-remote) volatile)
-           (prog1 (copy-file
-                   filename newname ok-if-already-exists keep-date
-                   preserve-uid-gid preserve-extended-attributes)
-             (delete-file filename)))
-
-          ;; We cannot copy or rename directly.
-          ((or (and equal-remote
-                    (tramp-get-connection-property v "direct-copy-failed"))
-               (and t1 (not (tramp-gvfs-file-name-p filename)))
-               (and t2 (not (tramp-gvfs-file-name-p newname))))
-           (let ((tmpfile (tramp-compat-make-temp-file filename)))
-             (if (eq op 'copy)
-                 (copy-file
-                  filename tmpfile t keep-date preserve-uid-gid
-                  preserve-extended-attributes)
-               (rename-file filename tmpfile t))
-             (rename-file tmpfile newname ok-if-already-exists)))
-
-          ;; Direct action.
-          (t (with-tramp-progress-reporter
-                 v 0 (format "%s %s to %s" msg-operation filename newname)
-               (unless
-                   (and (apply
-                         #'tramp-gvfs-send-command v gvfs-operation
-                         (append
-                          (and (eq op 'copy) (or keep-date preserve-uid-gid)
-                               '("--preserve"))
-                          (list
-                           (tramp-gvfs-url-file-name filename)
-                           (tramp-gvfs-url-file-name newname))))
-                        ;; Some backends do not return a proper error
-                        ;; code in case of direct copy/move.  Apply
-                        ;; sanity checks.
-                        (or (not equal-remote)
-                            (and
-                             (tramp-gvfs-info newname)
-                             (or (eq op 'copy)
-                                 (not (tramp-gvfs-info filename))))))
-
-                 (if (or (not equal-remote)
-                         (and equal-remote
-                              (tramp-get-connection-property
-                               v "direct-copy-failed")))
-                     ;; Propagate the error.
-                     (with-current-buffer (tramp-get-connection-buffer v)
-                       (goto-char (point-min))
-                       (tramp-error-with-buffer
-                        nil v 'file-error
-                        "%s failed, see buffer `%s' for details"
-                        msg-operation (buffer-name)))
-
-                   ;; Some WebDAV server, like the one from QNAP, do
-                   ;; not support direct copy/move.  Try a fallback.
-                   (tramp-set-connection-property v "direct-copy-failed" t)
-                   (tramp-gvfs-do-copy-or-rename-file
-                    op filename newname ok-if-already-exists keep-date
-                    preserve-uid-gid preserve-extended-attributes))))
-
-             (when (and t1 (eq op 'rename))
-               (with-parsed-tramp-file-name filename nil
-                 (tramp-flush-file-properties v localname)))
-
-             (when t2
-               (with-parsed-tramp-file-name newname nil
-                 (tramp-flush-file-properties v localname))))))))))
+           (cond
+            ;; We cannot rename volatile files, as used by Google-drive.
+            ((and (not equal-remote) volatile)
+             (prog1 (copy-file
+                     filename newname ok-if-already-exists keep-date
+                     preserve-uid-gid preserve-extended-attributes)
+               (delete-file filename)))
+
+            ;; We cannot copy or rename directly.
+            ((or (and equal-remote
+                      (tramp-get-connection-property v "direct-copy-failed"))
+                 (and t1 (not (tramp-gvfs-file-name-p filename)))
+                 (and t2 (not (tramp-gvfs-file-name-p newname))))
+             (let ((tmpfile (tramp-compat-make-temp-file filename)))
+               (if (eq op 'copy)
+                   (copy-file
+                    filename tmpfile t keep-date preserve-uid-gid
+                    preserve-extended-attributes)
+                 (rename-file filename tmpfile t))
+               (rename-file tmpfile newname ok-if-already-exists)))
+
+            ;; Direct action.
+            (t (with-tramp-progress-reporter
+                   v 0 (format "%s %s to %s" msg-operation filename newname)
+                 (unless
+                     (and (apply
+                           #'tramp-gvfs-send-command v gvfs-operation
+                           (append
+                            (and (eq op 'copy) (or keep-date preserve-uid-gid)
+                                 '("--preserve"))
+                            (list
+                             (tramp-gvfs-url-file-name filename)
+                             (tramp-gvfs-url-file-name newname))))
+                          ;; Some backends do not return a proper
+                          ;; error code in case of direct copy/move.
+                          ;; Apply sanity checks.
+                          (or (not equal-remote)
+                              (and
+                               (tramp-gvfs-info newname)
+                               (or (eq op 'copy)
+                                   (not (tramp-gvfs-info filename))))))
+
+                   (if (or (not equal-remote)
+                           (and equal-remote
+                                (tramp-get-connection-property
+                                 v "direct-copy-failed")))
+                       ;; Propagate the error.
+                       (with-current-buffer (tramp-get-connection-buffer v)
+                         (goto-char (point-min))
+                         (tramp-error-with-buffer
+                          nil v 'file-error
+                          "%s failed, see buffer `%s' for details"
+                          msg-operation (buffer-name)))
+
+                     ;; Some WebDAV server, like the one from QNAP,
+                     ;; do not support direct copy/move.  Try a
+                     ;; fallback.
+                     (tramp-set-connection-property v "direct-copy-failed" t)
+                     (tramp-gvfs-do-copy-or-rename-file
+                      op filename newname ok-if-already-exists keep-date
+                      preserve-uid-gid preserve-extended-attributes))))
+
+               (when (and t1 (eq op 'rename))
+                 (with-parsed-tramp-file-name filename nil
+                   (tramp-flush-file-properties v localname)))
+
+               (when t2
+                 (with-parsed-tramp-file-name newname nil
+                   (tramp-flush-file-properties v localname)))))))))))
 
 (defun tramp-gvfs-handle-copy-file
   (filename newname &optional ok-if-already-exists keep-date

diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 0e47248679fad25acc7f4cd925470215acaa86b2..b8e74a6348d3a9454a40fea42d70242f22396082 100644 (file)
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -251,6 +251,9 @@ arguments to pass to the OPERATION."
 (defun tramp-sshfs-handle-process-file
   (program &optional infile destination display &rest args)
   "Like `process-file' for Tramp files."
+  ;; STDERR is not impelmemted.
+  (when (consp destination)
+    (setcdr destination `(,tramp-cache-undefined)))
   (tramp-skeleton-process-file program infile destination display args
     (let ((coding-system-for-read 'utf-8-dos)) ; Is this correct?
 
@@ -260,25 +263,18 @@ arguments to pass to the OPERATION."
             (tramp-unquote-shell-quote-argument localname)
             (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))
       (when input (setq command (format "%s <%s" command input)))
-      (when stderr (setq command (format "%s 2>%s" command stderr)))
-
-      (unwind-protect
-         (setq ret
-               (apply
-                #'tramp-call-process
-                v (tramp-get-method-parameter v 'tramp-login-program)
-                nil outbuf display
-                (tramp-expand-args
-                 v 'tramp-login-args nil
-                 ?h (or (tramp-file-name-host v) "")
-                 ?u (or (tramp-file-name-user v) "")
-                 ?p (or (tramp-file-name-port v) "")
-                 ?a "-t" ?l command)))
-
-       ;; Synchronize stderr.
-       (when tmpstderr
-         (tramp-cleanup-connection v 'keep-debug 'keep-password)
-         (tramp-fuse-unmount v))))))
+
+      (setq ret
+           (apply
+            #'tramp-call-process
+            v (tramp-get-method-parameter v 'tramp-login-program)
+            nil outbuf display
+            (tramp-expand-args
+             v 'tramp-login-args nil
+             ?h (or (tramp-file-name-host v) "")
+             ?u (or (tramp-file-name-user v) "")
+             ?p (or (tramp-file-name-port v) "")
+             ?a "-t" ?l command))))))
 
 (defun tramp-sshfs-handle-rename-file
     (filename newname &optional ok-if-already-exists)

diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index cd35de44dc0cce65724d77f8788bf365b06b3031..4552ec52a9cc8bac5dd621f0c984f424b3896478 100644 (file)
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -3805,10 +3805,13 @@ BODY is the backend specific code."
                   tmpstderr (tramp-make-tramp-file-name v stderr))))
          ;; stderr to be discarded.
          ((null (cadr ,destination))
-          (setq stderr (tramp-get-remote-null-device v)))))
+          (setq stderr (tramp-get-remote-null-device v)))
+         ((eq (cadr ,destination) tramp-cache-undefined)
+          ;; stderr is not impelmemted.
+          (tramp-warning v "%s" "STDERR not supported"))))
        ;; t
        (,destination
-       (setq outbuf (current-buffer))))
+        (setq outbuf (current-buffer))))
 
        ,@body
 
@@ -5509,8 +5512,22 @@ support symbolic links."
                         (insert-file-contents-literally
                          error-file nil nil nil 'replace))
                       (delete-file error-file)))))
-               (display-buffer output-buffer '(nil (allow-no-window . t)))))
-
+                (if async-shell-command-display-buffer
+                    ;; Display buffer immediately.
+                    (display-buffer output-buffer '(nil (allow-no-window . t)))
+                  ;; Defer displaying buffer until first process output.
+                  ;; Use disposable named advice so that the buffer is
+                  ;; displayed at most once per process lifetime.
+                  (let ((nonce (make-symbol "nonce")))
+                    (add-function
+                    :before (process-filter p)
+                     (lambda (proc _string)
+                       (let ((buf (process-buffer proc)))
+                         (when (buffer-live-p buf)
+                           (remove-function (process-filter proc)
+                                            nonce)
+                           (display-buffer buf '(nil (allow-no-window . t))))))
+                     `((name . ,nonce)))))))
            ;; Insert error messages if they were separated.
            (when (and error-file (not (process-live-p p)))
              (ignore-errors

diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index dd23bd325cb85b3766451231632e685a7a3576dc..ecbb8744b9aa6928c6c2fbabf027538a3cef13b0 100644 (file)
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -4995,19 +4995,20 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
            ;;  (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
-                 (rx "cat:" (* nonl) " No such file or directory")
-                 (buffer-string)))
-               (should-not (get-buffer-window (current-buffer) t))
-               (delete-file tmp-name))))
+           (unless (tramp--test-sshfs-p)
+             (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
+                   (rx "cat:" (* nonl) " 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))