From 79cc9445e182ad5d80380ccf677b947d76854ce8 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 27 Aug 2017 19:16:58 +0200 Subject: [PATCH] Tramp cleanup * lisp/net/tramp-sh.el (tramp-sh-extra-args): Remove compat code. (tramp-sh-handle-make-symbolic-link): More robust check for TARGET remoteness. * lisp/net/tramp-smb.el (tramp-smb-handle-copy-directory): Disable copying by tar temporarily, it doesn't work reliably. (tramp-smb-do-file-attributes-with-stat): Resolve symlink. (tramp-smb-handle-make-symbolic-link): Fix implementation. * lisp/net/tramp.el (tramp-handle-file-symlink-p): Simplify. * test/lisp/net/tramp-tests.el (tramp-test21-file-links): Extend test. --- lisp/net/tramp-sh.el | 11 ++--- lisp/net/tramp-smb.el | 87 +++++++++++++++++++----------------- lisp/net/tramp.el | 8 +--- test/lisp/net/tramp-tests.el | 67 ++++++++++++++++++++++----- 4 files changed, 109 insertions(+), 64 deletions(-) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6251248e282..6494b0957bf 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -562,11 +562,7 @@ This variable is only used when Tramp needs to start up another shell for tilde expansion. The extra arguments should typically prevent the shell from reading its init file." :group 'tramp - ;; This might be the wrong way to test whether the widget type - ;; `alist' is available. Who knows the right way to test it? - :type (if (get 'alist 'widget-type) - '(alist :key-type string :value-type string) - '(repeat (cons string string))) + :type '(alist :key-type regexp :value-type string) :require 'tramp) (defconst tramp-actions-before-shell @@ -1088,8 +1084,9 @@ component is used as the target of the symlink." (delete-file linkname))) ;; If TARGET is a Tramp name, use just the localname component. - (when (tramp-file-name-equal-p - v (tramp-dissect-file-name (expand-file-name target))) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p + v (tramp-dissect-file-name (expand-file-name target)))) (setq target (tramp-file-name-localname (tramp-dissect-file-name (expand-file-name target))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index f734b80d535..920e10331ba 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -430,7 +430,8 @@ pass to the OPERATION." (delete-directory tmpdir 'recursive)))) ;; We can copy recursively. - ((and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + ;; Does not work reliably. + (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) (when (and (file-directory-p newname) (not (string-equal (file-name-nondirectory dirname) (file-name-nondirectory newname)))) @@ -888,6 +889,16 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1)))))) ;; year (forward-line)) + + ;; Resolve symlink. + (when (and (stringp id) + (tramp-smb-send-command + vec + (format "readlink \"%s\"" (tramp-smb-get-localname vec)))) + (goto-char (point-min)) + (and (looking-at ".+ -> \\(.+\\)") + (setq id (match-string 1)))) + ;; Return the result. (list id link uid gid atime mtime ctime size mode nil inode (tramp-get-device vec))))))) @@ -1105,47 +1116,43 @@ component is used as the target of the symlink." (tramp-run-real-handler 'make-symbolic-link (list target linkname ok-if-already-exists)) - (unless (tramp-equal-remote target linkname) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p target) target linkname) nil + (with-parsed-tramp-file-name linkname nil + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + localname))))) + (tramp-error v 'file-already-exists localname) + (delete-file linkname))) + + (unless (tramp-smb-get-cifs-capabilities v) + (tramp-error v 'file-error "make-symbolic-link not supported")) + + ;; If TARGET is a Tramp name, use just the localname component. + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p + v (tramp-dissect-file-name (expand-file-name target)))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target))))) + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + + (unless + (tramp-smb-send-command + v + (format "symlink \"%s\" \"%s\"" target (tramp-smb-get-localname v))) (tramp-error v 'file-error - "make-symbolic-link: %s" - "only implemented for same method, same user, same host"))) - (with-parsed-tramp-file-name target v1 - (with-parsed-tramp-file-name linkname v2 - (when (file-directory-p target) - (tramp-error - v2 'file-error - "make-symbolic-link: %s must not be a directory" target)) - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway? " - v2-localname))))) - (tramp-error v2 'file-already-exists v2-localname) - (delete-file linkname))) - (unless (tramp-smb-get-cifs-capabilities v1) - (tramp-error v2 'file-error "make-symbolic-link not supported")) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) - (unless - (tramp-smb-send-command - v1 - (format - "symlink \"%s\" \"%s\"" - (tramp-smb-get-localname v1) - (tramp-smb-get-localname v2))) - (tramp-error - v2 'file-error - "error with make-symbolic-link, see buffer `%s' for details" - (buffer-name))))))) + "error with make-symbolic-link, see buffer `%s' for details" + (buffer-name)))))) (defun tramp-smb-handle-process-file (program &optional infile destination display &rest args) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index bb68b9e9645..1a5cda7e20d 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3065,12 +3065,8 @@ User is always nil." (defun tramp-handle-file-symlink-p (filename) "Like `file-symlink-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) - (when (stringp x) - (if (file-name-absolute-p x) - (tramp-make-tramp-file-name method user domain host port x) - x))))) + (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) + (and (stringp x) x))) (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3dbb522a7cd..e7a55c41cf1 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2586,14 +2586,50 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (string-equal (error-message-string err) "make-symbolic-link not supported"))))) - (should (file-symlink-p tmp-name2)) - (should-error (make-symbolic-link tmp-name1 tmp-name2) - :type 'file-already-exists) + (should + (string-equal + (funcall + (if quoted 'tramp-compat-file-name-unquote 'identity) + (file-remote-p tmp-name1 'localname)) + (file-symlink-p tmp-name2))) + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-already-exists) + ;; 0 means interactive case. + (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))) + (make-symbolic-link tmp-name1 tmp-name2 0) + (should + (string-equal + (funcall + (if quoted 'tramp-compat-file-name-unquote 'identity) + (file-remote-p tmp-name1 'localname)) + (file-symlink-p tmp-name2)))) (make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists) - (should (file-symlink-p tmp-name2)) - ;; `tmp-name3' is a local file name. + (should + (string-equal + (funcall + (if quoted 'tramp-compat-file-name-unquote 'identity) + (file-remote-p tmp-name1 'localname)) + (file-symlink-p tmp-name2))) + ;; If we use the local part of `tmp-name1', it shall still work. + (make-symbolic-link + (file-remote-p tmp-name1 'localname) + tmp-name2 'ok-if-already-exists) + (should + (string-equal + (funcall + (if quoted 'tramp-compat-file-name-unquote 'identity) + (file-remote-p tmp-name1 'localname)) + (file-symlink-p tmp-name2))) + ;; `tmp-name3' is a local file name. Therefore, the link + ;; target remains unchanged, even if quoted. (make-symbolic-link tmp-name1 tmp-name3) - (should (file-symlink-p tmp-name3))) + (should + (string-equal tmp-name1 (file-symlink-p tmp-name3)))) ;; Cleanup. (ignore-errors @@ -2607,11 +2643,21 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) (add-name-to-file tmp-name1 tmp-name2) - (should-not (file-symlink-p tmp-name2)) - (should-error (add-name-to-file tmp-name1 tmp-name2) - :type 'file-already-exists) + (should (file-regular-p tmp-name2)) + (should-error + (add-name-to-file tmp-name1 tmp-name2) + :type 'file-already-exists) + ;; 0 means interactive case. + (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))) + (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) (should-not (file-symlink-p tmp-name2)) + (should (file-regular-p tmp-name2)) ;; `tmp-name3' is a local file name. (should-error (add-name-to-file tmp-name1 tmp-name3))) @@ -2640,8 +2686,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (file-truename tmp-name1) - (funcall - 'tramp-compat-file-name-unquote (file-truename tmp-name3))))) + (tramp-compat-file-name-unquote (file-truename tmp-name3))))) ;; Cleanup. (ignore-errors -- 2.39.2