master f00af4b: Complete implementation of `copy-directory-create-symlink' in Tramp

[Michael Albinus]

branch: master
commit f00af4be3d8c14fc83925dcd244701c0dce7604a
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    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 9dcf553..e0bc28c 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 6937244..5cfe874 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 4e409fc..127a9be 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',