From: Michael Albinus Date: Wed, 19 Mar 2025 13:40:54 +0000 (+0100) Subject: ; Tramp: fixes resulting from test campaign X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=89f3ac161cf637ecbf209556043081c8f8c43d42;p=emacs.git ; 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 45b8e53de3b..0ea9f4bb66c 100644 --- 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 0e47248679f..b8e74a6348d 100644 --- 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 cd35de44dc0..4552ec52a9c 100644 --- 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 dd23bd325cb..ecbb8744b9a 100644 --- 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))