master 657fe8b: Allow copy-directory to copy the source as a symlink

[Lars Ingebrigtsen]

branch: master
commit 657fe8b9d87dd17d9b50dd8e15bfd917c6c630b2
Author: Marco Centurion <mcenturion@fing.edu.uy>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Allow copy-directory to copy the source as a symlink
    
    * doc/emacs/files.texi (Copying and Naming): Document it.
    
    * lisp/files.el (copy-directory): Allow copying symbolic links as
    is (bug#10897).
    (copy-directory-create-symlink): New user option.
    
    Copyright-paperwork-exempt: yes
---
 doc/emacs/files.texi |  6 +++-
 etc/NEWS             |  5 +++
 lisp/files.el        | 95 ++++++++++++++++++++++++++++++++--------------------
 3 files changed, 69 insertions(+), 37 deletions(-)

diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 8304e40..207c951 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -1728,12 +1728,16 @@ exists.
   @kbd{M-x copy-file} copies the contents of the file @var{old} to the
 file @var{new}.
 
+@vindex copy-directory-create-symlink
 @findex copy-directory
   @kbd{M-x copy-directory} copies directories, similar to the
 @command{cp -r} shell command.  If @var{new} is a directory name, it
 creates a copy of the @var{old} directory and puts it in @var{new}.
 Otherwise it copies all the contents of @var{old} into a new directory
-named @var{new}.
+named @var{new}.  If @code{copy-directory-create-symlink} is
+non-@code{nil} and @var{old} is a symbolic link, this command will
+copy the symbolic link.  If @code{nil}, this command will follow the
+link and copy the contents instead.  (This is the default.)
 
 @cindex renaming files
 @findex rename-file
diff --git a/etc/NEWS b/etc/NEWS
index b221f13..7cd0c5f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2461,6 +2461,11 @@ images are marked.
 ** Miscellaneous
 
 +++
+*** New user option 'copy-directory-create-symlink'.
+If non-nil, will make `copy-directory' (when used on a symbolic
+link) copy the link instead of following the link.
+
++++
 *** New function 'replace-regexp-in-region'.
 
 +++
diff --git a/lisp/files.el b/lisp/files.el
index 77977f1..90de149 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -5437,6 +5437,15 @@ Used only by `save-buffer'."
   :type 'hook
   :group 'files)
 
+(defcustom copy-directory-create-symlink nil
+  "This option influences the handling of symbolic links in `copy-directory'.
+If non-nil, `copy-directory' will create a symbolic link if the
+source directory is a symbolic link.  If nil, it'll follow the
+symbolic link and copy the contents instead."
+  :type 'boolean
+  :version "28.1"
+  :group 'files)
+
 (defvar-local save-buffer-coding-system nil
   "If non-nil, use this coding system for saving the buffer.
 More precisely, use this coding system in place of the
@@ -6165,6 +6174,9 @@ Noninteractively, the PARENTS argument says whether to 
create
 parent directories if they don't exist.  Interactively, this
 happens by default.
 
+If DIRECTORY is a symlink and `copy-directory-create-symlink' is
+non-nil, create a symlink with the same target as DIRECTORY.
+
 If NEWNAME is a directory name, copy DIRECTORY as a subdirectory
 there.  However, if called from Lisp with a non-nil optional
 argument COPY-CONTENTS, copy the contents of DIRECTORY directly
@@ -6193,42 +6205,53 @@ into NEWNAME instead."
       (setq directory (directory-file-name (expand-file-name directory))
            newname (expand-file-name newname))
 
-      (cond ((not (directory-name-p newname))
-            ;; If NEWNAME is not a directory name, create it;
-            ;; that is where we will copy the files of DIRECTORY.
-            (make-directory newname parents))
-           ;; NEWNAME is a directory name.  If COPY-CONTENTS is non-nil,
-           ;; create NEWNAME if it is not already a directory;
-           ;; otherwise, create NEWNAME/[DIRECTORY-BASENAME].
-           ((if copy-contents
-                (or parents (not (file-directory-p newname)))
-              (setq newname (concat newname
-                                    (file-name-nondirectory directory))))
-            (make-directory (directory-file-name newname) parents))
-           (t (setq follow t)))
-
-      ;; Copy recursively.
-      (dolist (file
-              ;; We do not want to copy "." and "..".
-              (directory-files directory 'full
-                               directory-files-no-dot-files-regexp))
-       (let ((target (concat (file-name-as-directory newname)
-                             (file-name-nondirectory file)))
-             (filetype (car (file-attributes file))))
-         (cond
-          ((eq filetype t)       ; Directory but not a symlink.
-           (copy-directory file target keep-time parents t))
-          ((stringp filetype)    ; Symbolic link
-           (make-symbolic-link filetype target t))
-          ((copy-file file target t keep-time)))))
-
-      ;; Set directory attributes.
-      (let ((modes (file-modes directory))
-           (times (and keep-time (file-attribute-modification-time
-                                  (file-attributes directory))))
-           (follow-flag (unless follow 'nofollow)))
-       (if modes (set-file-modes newname modes follow-flag))
-       (if times (set-file-times newname times follow-flag))))))
+      ;; If DIRECTORY is a symlink, create a symlink with the same target.
+      (if (and (file-symlink-p directory)
+               copy-directory-create-symlink)
+          (let ((target (car (file-attributes directory))))
+           (if (directory-name-p newname)
+               (make-symbolic-link target
+                                   (concat newname
+                                           (file-name-nondirectory directory))
+                                   t)
+             (make-symbolic-link target newname t)))
+        ;; Else proceed to copy as a regular directory
+        (cond ((not (directory-name-p newname))
+              ;; If NEWNAME is not a directory name, create it;
+              ;; that is where we will copy the files of DIRECTORY.
+              (make-directory newname parents))
+             ;; NEWNAME is a directory name.  If COPY-CONTENTS is non-nil,
+             ;; create NEWNAME if it is not already a directory;
+             ;; otherwise, create NEWNAME/[DIRECTORY-BASENAME].
+             ((if copy-contents
+                  (or parents (not (file-directory-p newname)))
+                (setq newname (concat newname
+                                      (file-name-nondirectory directory))))
+              (make-directory (directory-file-name newname) parents))
+             (t (setq follow t)))
+
+        ;; Copy recursively.
+        (dolist (file
+                ;; We do not want to copy "." and "..".
+                (directory-files directory 'full
+                                 directory-files-no-dot-files-regexp))
+         (let ((target (concat (file-name-as-directory newname)
+                               (file-name-nondirectory file)))
+               (filetype (car (file-attributes file))))
+           (cond
+            ((eq filetype t)           ; Directory but not a symlink.
+             (copy-directory file target keep-time parents t))
+            ((stringp filetype)        ; Symbolic link
+             (make-symbolic-link filetype target t))
+            ((copy-file file target t keep-time)))))
+
+        ;; Set directory attributes.
+        (let ((modes (file-modes directory))
+             (times (and keep-time (file-attribute-modification-time
+                                    (file-attributes directory))))
+             (follow-flag (unless follow 'nofollow)))
+         (if modes (set-file-modes newname modes follow-flag))
+         (if times (set-file-times newname times follow-flag)))))))
 
 
 ;; At time of writing, only info uses this.