master f405756: Implement `copy-directory-create-symlink' for remote files

[Michael Albinus]

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

    Implement `copy-directory-create-symlink' for remote files
    
    * lisp/net/tramp-sh.el (tramp-sh-handle-copy-directory):
    Implement `copy-directory-create-symlink'.  (Bug#10897)
    
    * test/lisp/net/tramp-tests.el (tramp-test15-copy-directory):
    Extend test.
---
 lisp/net/tramp-sh.el         | 65 ++++++++++++++++++++++++--------------------
 test/lisp/net/tramp-tests.el | 30 ++++++++++++++++++--
 2 files changed, 64 insertions(+), 31 deletions(-)

diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index f00434c..9dcf553 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -1861,37 +1861,44 @@ ID-FORMAT valid values are `string' and `integer'."
     (with-parsed-tramp-file-name (if t1 dirname newname) nil
       (unless (file-exists-p dirname)
        (tramp-compat-file-missing v dirname))
-      (if (and (not copy-contents)
-              (tramp-get-method-parameter v 'tramp-copy-recursive)
-              ;; When DIRNAME and NEWNAME are remote, they must have
-              ;; the same method.
-              (or (null t1) (null t2)
-                  (string-equal
-                   (tramp-file-name-method (tramp-dissect-file-name dirname))
-                   (tramp-file-name-method
-                    (tramp-dissect-file-name newname)))))
-         ;; scp or rsync DTRT.
-         (progn
-           (when (and (file-directory-p newname)
-                      (not (directory-name-p newname)))
-             (tramp-error v 'file-already-exists newname))
-           (setq dirname (directory-file-name (expand-file-name dirname))
-                 newname (directory-file-name (expand-file-name newname)))
-           (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)))
-           (unless (file-directory-p (file-name-directory newname))
+
+      ;; `copy-directory-create-symlink' exists since Emacs 28.1.
+      (if (and (bound-and-true-p copy-directory-create-symlink)
+              (file-symlink-p dirname)
+              (tramp-equal-remote dirname newname))
+         (make-symbolic-link (file-symlink-p dirname) newname)
+
+       (if (and (not copy-contents)
+                (tramp-get-method-parameter v 'tramp-copy-recursive)
+                ;; When DIRNAME and NEWNAME are remote, they must
+                ;; have the same method.
+                (or (null t1) (null t2)
+                    (string-equal
+                     (tramp-file-name-method (tramp-dissect-file-name dirname))
+                     (tramp-file-name-method
+                      (tramp-dissect-file-name newname)))))
+           ;; scp or rsync DTRT.
+           (progn
+             (when (and (file-directory-p newname)
+                        (not (directory-name-p newname)))
+               (tramp-error v 'file-already-exists newname))
+             (setq dirname (directory-file-name (expand-file-name dirname))
+                   newname (directory-file-name (expand-file-name newname)))
+             (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)))
+             (unless (file-directory-p (file-name-directory newname))
                (make-directory (file-name-directory newname) parents))
-           (tramp-do-copy-or-rename-file-out-of-band
-            'copy dirname newname 'ok-if-already-exists keep-date))
+             (tramp-do-copy-or-rename-file-out-of-band
+              'copy dirname newname 'ok-if-already-exists keep-date))
 
-       ;; We must do it file-wise.
-       (tramp-run-real-handler
-        #'copy-directory
-        (list dirname newname keep-date parents copy-contents)))
+         ;; We must do it file-wise.
+         (tramp-run-real-handler
+          #'copy-directory
+          (list dirname newname keep-date parents copy-contents))))
 
       ;; When newname did exist, we have wrong cached values.
       (when t2
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index ee0601f..4e409fc 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2866,7 +2866,8 @@ This tests also `file-directory-p' and 
`file-accessible-directory-p'."
                       (file-name-nondirectory tmp-name1) tmp-name2))
           (tmp-name4 (expand-file-name "foo" tmp-name1))
           (tmp-name5 (expand-file-name "foo" tmp-name2))
-          (tmp-name6 (expand-file-name "foo" tmp-name3)))
+          (tmp-name6 (expand-file-name "foo" tmp-name3))
+          (tmp-name7 (tramp--test-make-temp-name nil quoted)))
 
       ;; Copy complete directory.
       (unwind-protect
@@ -2922,7 +2923,32 @@ This tests also `file-directory-p' and 
`file-accessible-directory-p'."
        ;; Cleanup.
        (ignore-errors
          (delete-directory tmp-name1 'recursive)
-         (delete-directory tmp-name2 'recursive))))))
+         (delete-directory tmp-name2 'recursive)))
+
+      ;; Copy symlink to directory.  Implemented since Emacs 28.1.
+      (when (and (tramp--test-emacs28-p) (tramp--test-sh-p))
+       (dolist (copy-directory-create-symlink '(nil t))
+         (unwind-protect
+             (progn
+               ;; Copy empty directory.
+               (make-directory tmp-name1)
+               (write-region "foo" nil tmp-name4)
+               (make-symbolic-link tmp-name1 tmp-name7)
+               (should (file-directory-p tmp-name1))
+               (should (file-exists-p tmp-name4))
+               (should (file-symlink-p tmp-name7))
+               (copy-directory tmp-name7 tmp-name2)
+               (if copy-directory-create-symlink
+                   (should
+                    (string-equal
+                     (file-symlink-p tmp-name2) (file-symlink-p tmp-name7)))
+                 (should (file-directory-p tmp-name2))))
+
+           ;; Cleanup.
+           (ignore-errors
+             (delete-directory tmp-name1 'recursive)
+             (delete-directory tmp-name2 'recursive)
+             (delete-directory tmp-name7 'recursive))))))))
 
 (ert-deftest tramp-test16-directory-files ()
   "Check `directory-files'."