From f00af4be3d8c14fc83925dcd244701c0dce7604a Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 23 Aug 2021 15:47:19 +0200 Subject: [PATCH] Complete implementation of `copy-directory-create-symlink' in Tramp * lisp/net/tramp-sh.el (tramp-sh-handle-copy-directory): Fix the case NEWNAME is a directory name with a trailing slash. * lisp/net/tramp-smb.el (tramp-smb-handle-copy-directory): Implement `copy-directory-create-symlink'. (Bug#10897) * test/lisp/net/tramp-tests.el (tramp--test-ignore-make-symbolic-link-error): Move up. (tramp-test15-copy-directory): Extend test. --- lisp/net/tramp-sh.el | 11 +- lisp/net/tramp-smb.el | 311 +++++++++++++++++++---------------- test/lisp/net/tramp-tests.el | 50 ++++-- 3 files changed, 206 insertions(+), 166 deletions(-) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 9dcf55340c2..e0bc28c983f 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1857,16 +1857,21 @@ ID-FORMAT valid values are `string' and `integer'." (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) + (t2 (tramp-tramp-file-p newname)) + target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) (tramp-compat-file-missing v dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) - (file-symlink-p dirname) + (setq target (file-symlink-p dirname)) (tramp-equal-remote dirname newname)) - (make-symbolic-link (file-symlink-p dirname) newname) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) (if (and (not copy-contents) (tramp-get-method-parameter v 'tramp-copy-recursive) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 69372449172..5cfe874f00a 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -414,157 +414,176 @@ arguments to pass to the OPERATION." (defun tramp-smb-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (if copy-contents - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory (list dirname newname keep-date parents copy-contents)) - - (setq dirname (expand-file-name dirname) - newname (expand-file-name newname)) - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" dirname newname) - (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (cond - ;; We must use a local temporary directory. - ((and t1 t2) - (let ((tmpdir (tramp-compat-make-temp-name))) - (unwind-protect - (progn - (make-directory tmpdir) - (copy-directory - dirname (file-name-as-directory tmpdir) keep-date 'parents) - (copy-directory - (expand-file-name (file-name-nondirectory dirname) tmpdir) - newname keep-date parents)) - (delete-directory tmpdir 'recursive)))) - - ;; We can copy recursively. - ;; TODO: Does not work reliably. - (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname)) + target) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (unless (file-exists-p dirname) + (tramp-compat-file-missing v dirname)) + + ;; `copy-directory-create-symlink' exists since Emacs 28.1. + (if (and (bound-and-true-p copy-directory-create-symlink) + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) + + (if copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents)) + + (setq dirname (expand-file-name dirname) + newname (expand-file-name newname)) + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" dirname newname) + (unless (file-exists-p dirname) + (tramp-compat-file-missing v dirname)) (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname)) - (if t2 (setq v (tramp-dissect-file-name newname)))) - (if (not (file-directory-p newname)) - (make-directory newname parents)) - - (let* ((share (tramp-smb-get-share v)) - (localname (file-name-as-directory - (tramp-compat-string-replace - "\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (tramp-compat-make-temp-name)) - (args (list (concat "//" host "/" share) "-E")) - (options tramp-smb-options)) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (while options + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (cond + ;; We must use a local temporary directory. + ((and t1 t2) + (let ((tmpdir (tramp-compat-make-temp-name))) + (unwind-protect + (progn + (make-directory tmpdir) + (copy-directory + dirname (file-name-as-directory tmpdir) + keep-date 'parents) + (copy-directory + (expand-file-name (file-name-nondirectory dirname) tmpdir) + newname keep-date parents)) + (delete-directory tmpdir 'recursive)))) + + ;; We can copy recursively. + ;; TODO: 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)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname)) + (if t2 (setq v (tramp-dissect-file-name newname)))) + (if (not (file-directory-p newname)) + (make-directory newname parents)) + + (let* ((share (tramp-smb-get-share v)) + (localname (file-name-as-directory + (tramp-compat-string-replace + "\\" "/" (tramp-smb-get-localname v)))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) + + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args - (append args `("--option" ,(format "%s" (car options)))) - options (cdr options))) - (setq args - (if t1 - ;; Source is remote. - (append args + (if t1 + ;; Source is remote. + (append args + (list "-D" (tramp-unquote-shell-quote-argument + localname) + "-c" (tramp-unquote-shell-quote-argument + "tar qc - *") + "|" "tar" "xfC" "-" + (tramp-unquote-shell-quote-argument + tmpdir))) + ;; Target is remote. + (append (list + "tar" "cfC" "-" + (tramp-unquote-shell-quote-argument dirname) + "." "|") + args (list "-D" (tramp-unquote-shell-quote-argument localname) "-c" (tramp-unquote-shell-quote-argument - "tar qc - *") - "|" "tar" "xfC" "-" - (tramp-unquote-shell-quote-argument - tmpdir))) - ;; Target is remote. - (append (list "tar" "cfC" "-" - (tramp-unquote-shell-quote-argument dirname) - "." "|") - args - (list "-D" (tramp-unquote-shell-quote-argument - localname) - "-c" (tramp-unquote-shell-quote-argument - "tar qx -"))))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - (when t1 - ;; The smbclient tar command creates always - ;; complete paths. We must emulate the - ;; directory structure, and symlink to the real - ;; target. - (make-directory - (expand-file-name - ".." (concat tmpdir localname)) - 'parents) - (make-symbolic-link - newname (directory-file-name (concat tmpdir localname)))) - - ;; Use an asynchronous processes. By this, - ;; password can be handled. - (let* ((default-directory tmpdir) - (p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-program args))) - - (tramp-message - v 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector v) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-with-tar) - - (while (process-live-p p) - (sleep-for 0.1)) - (tramp-message v 6 "\n%s" (buffer-string)))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - (when t1 (delete-directory tmpdir 'recursive)))) - - ;; Handle KEEP-DATE argument. - (when keep-date - (tramp-compat-set-file-times - newname - (tramp-compat-file-attribute-modification-time - (file-attributes dirname)) - (unless ok-if-already-exists 'nofollow))) - - ;; Set the mode. - (unless keep-date - (set-file-modes newname (tramp-default-file-modes dirname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname)))) - - ;; We must do it file-wise. - (t - (tramp-run-real-handler - #'copy-directory (list dirname newname keep-date parents))))))))) + "tar qx -"))))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + (when t1 + ;; The smbclient tar command creates always + ;; complete paths. We must emulate the + ;; directory structure, and symlink to the + ;; real target. + (make-directory + (expand-file-name + ".." (concat tmpdir localname)) + 'parents) + (make-symbolic-link + newname + (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By this, + ;; password can be handled. + (let* ((default-directory tmpdir) + (p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-program args))) + + (tramp-message + v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions + p v nil tramp-smb-actions-with-tar) + + (while (process-live-p p) + (sleep-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + (when t1 (delete-directory tmpdir 'recursive)))) + + ;; Handle KEEP-DATE argument. + (when keep-date + (tramp-compat-set-file-times + newname + (tramp-compat-file-attribute-modification-time + (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) + + ;; Set the mode. + (unless keep-date + (set-file-modes newname (tramp-default-file-modes dirname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))) + + ;; We must do it file-wise. + (t + (tramp-run-real-handler + #'copy-directory (list dirname newname keep-date parents)))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 4e409fcbf04..127a9bee955 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -177,6 +177,19 @@ The temporary file is not created." (make-temp-name "tramp-test") (if local temporary-file-directory tramp-test-temporary-file-directory)))) +;; Method "smb" supports `make-symbolic-link' only if the remote host +;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el +;; and tramp-sshfs.el do not support symbolic links at all. +(defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) + "Run BODY, ignoring \"make-symbolic-link not supported\" file error." + (declare (indent defun) (debug (body))) + `(condition-case err + (progn ,@body) + (file-error + (unless (string-equal (error-message-string err) + "make-symbolic-link not supported") + (signal (car err) (cdr err)))))) + ;; Don't print messages in nested `tramp--test-instrument-test-case' calls. (defvar tramp--test-instrument-test-case-p nil "Whether `tramp--test-instrument-test-case' run. @@ -2926,11 +2939,11 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (delete-directory tmp-name2 'recursive))) ;; Copy symlink to directory. Implemented since Emacs 28.1. - (when (and (tramp--test-emacs28-p) (tramp--test-sh-p)) + (when (boundp 'copy-directory-create-symlink) (dolist (copy-directory-create-symlink '(nil t)) (unwind-protect - (progn - ;; Copy empty directory. + (tramp--test-ignore-make-symbolic-link-error + ;; Copy to file name. (make-directory tmp-name1) (write-region "foo" nil tmp-name4) (make-symbolic-link tmp-name1 tmp-name7) @@ -2942,7 +2955,23 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should (string-equal (file-symlink-p tmp-name2) (file-symlink-p tmp-name7))) - (should (file-directory-p tmp-name2)))) + (should (file-directory-p tmp-name2))) + ;; Copy to directory name. + (delete-directory tmp-name2 'recursive) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (copy-directory tmp-name7 (file-name-as-directory tmp-name2)) + (if copy-directory-create-symlink + (should + (string-equal + (file-symlink-p + (expand-file-name + (file-name-nondirectory tmp-name7) tmp-name2)) + (file-symlink-p tmp-name7))) + (should + (file-directory-p + (expand-file-name + (file-name-nondirectory tmp-name7) tmp-name2))))) ;; Cleanup. (ignore-errors @@ -3292,19 +3321,6 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ignore-errors (kill-buffer buffer)) (ignore-errors (delete-directory tmp-name1 'recursive)))))) -;; Method "smb" supports `make-symbolic-link' only if the remote host -;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el -;; and tramp-sshfs.el do not support symbolic links at all. -(defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) - "Run BODY, ignoring \"make-symbolic-link not supported\" file error." - (declare (indent defun) (debug (body))) - `(condition-case err - (progn ,@body) - (file-error - (unless (string-equal (error-message-string err) - "make-symbolic-link not supported") - (signal (car err) (cdr err)))))) - (ert-deftest tramp-test18-file-attributes () "Check `file-attributes'. This tests also `access-file', `file-readable-p', -- 2.39.5