mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-16 17:24:23 +00:00
; 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.
This commit is contained in:
Michael Albinus
parent
fa1cfcada0
commit
f6632114fe
4 changed files with 140 additions and 120 deletions
|
|
@ -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")))
|
||||
(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))
|
||||
(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)))
|
||||
(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)))
|
||||
;; 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))))))
|
||||
;; 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)))
|
||||
(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))))
|
||||
;; 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 (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))))))))))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -3810,10 +3810,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
|
||||
|
||||
|
|
@ -5514,8 +5517,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
|
||||
|
|
|
|||
|
|
@ -5309,19 +5309,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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue