Re: bug in copy-directory

[Thierry Volpiatto <thierry.volpiatto@gmail.com>]

Thierry Volpiatto <thierry.volpiatto@gmail.com> writes:

> Michael Albinus <michael.albinus@gmx.de> writes:
>
>> Thierry Volpiatto <thierry.volpiatto@gmail.com> writes:
>>
>>> Following patch seems to work in these cases, could you check?
>>
>> Still the same problem.
> Ah! yes didn't notice it create a third /test nested in the second one.
Can you try this one now (interactively and not):
It should work.

---
 lisp/files.el |   87 ++++++++++++++++++++++++++++++---------------------------
 1 files changed, 46 insertions(+), 41 deletions(-)

diff --git a/lisp/files.el b/lisp/files.el
index 4659742..e465157 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4723,6 +4723,7 @@ If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well."
 		 directory 'full directory-files-no-dot-files-regexp)))
       (delete-directory-internal directory)))))
 
+
 (defun copy-directory (directory newname &optional keep-time parents)
   "Copy DIRECTORY to NEWNAME.  Both args must be strings.
 If NEWNAME names an existing directory, copy DIRECTORY as subdirectory there.
@@ -4748,50 +4749,54 @@ this happens by default."
 	   current-prefix-arg t)))
   ;; If default-directory is a remote directory, make sure we find its
   ;; copy-directory handler.
-  (let ((handler (or (find-file-name-handler directory 'copy-directory)
-		     (find-file-name-handler newname 'copy-directory))))
+  (let ((handler   (or (find-file-name-handler directory 'copy-directory)
+                       (find-file-name-handler newname 'copy-directory)))
+        (dir-files (directory-files directory 'full directory-files-no-dot-files-regexp)))
     (if handler
 	(funcall handler 'copy-directory directory newname keep-time parents)
 
-      ;; Compute target name.
-      (setq directory (directory-file-name (expand-file-name directory))
-	    newname   (directory-file-name (expand-file-name newname)))
-
-      (if (not (file-directory-p newname))
-	  ;; If NEWNAME is not an existing directory, create it; that
-	  ;; is where we will copy the files of DIRECTORY.
-	  (make-directory newname parents)
-	;; If NEWNAME is an existing directory, we will copy into
-	;; NEWNAME/[DIRECTORY-BASENAME].
-	(setq newname (expand-file-name
-		       (file-name-nondirectory
-			(directory-file-name directory))
-		       newname))
-	(if (and (file-exists-p newname)
-		 (not (file-directory-p newname)))
-	    (error "Cannot overwrite non-directory %s with a directory"
-		   newname))
-	(make-directory newname t))
-
-      ;; Copy recursively.
-      (mapc
-       (lambda (file)
-	 (let ((target (expand-file-name
-			(file-name-nondirectory file) newname))
-	       (attrs (file-attributes file)))
-	   (cond ((file-directory-p file)
-		  (copy-directory file target keep-time parents))
-		 ((stringp (car attrs)) ; Symbolic link
-		  (make-symbolic-link (car attrs) target t))
-		 (t
-		  (copy-file file target t keep-time)))))
-       ;; We do not want to copy "." and "..".
-       (directory-files	directory 'full directory-files-no-dot-files-regexp))
-
-      ;; Set directory attributes.
-      (set-file-modes newname (file-modes directory))
-      (if keep-time
-	  (set-file-times newname (nth 5 (file-attributes directory)))))))
+        ;; Compute target name.
+        ;; (setq directory (directory-file-name (expand-file-name directory))
+        ;;       newname   (directory-file-name (expand-file-name newname)))
+        ;; (if (not (file-directory-p newname)) (make-directory newname parents))
+        (setq directory (directory-file-name (expand-file-name directory)))
+        (setq newname   (directory-file-name (if (file-directory-p newname)
+                                                 (expand-file-name
+                                                  (file-relative-name directory
+                                                                      (file-name-directory directory))
+                                                  newname)
+                                                 newname)))
+        (if (file-directory-p newname)
+            (when (and (interactive-p)
+                       (y-or-n-p (format "Directory `%s' exists, overwrite? " newname)))
+              (delete-directory newname t)
+              (make-directory newname 'parents))
+            (make-directory newname 'parents))
+
+        (when (> (length dir-files) 0)
+          (let ((allow-recurse  (or (and (interactive-p)
+                                         (y-or-n-p (format "Recursive copies of `%s'? " directory)))
+                                    t))) ; always allow recursive copy in non--interactive calls.
+            (when allow-recurse
+              ;; Copy recursively.
+              (mapc
+               (lambda (file)
+                 (let ((target (expand-file-name
+                                (file-name-nondirectory file) newname))
+                       (attrs (file-attributes file)))
+                   (cond ((file-directory-p file)
+                          (copy-directory file target keep-time parents))
+                         ((stringp (car attrs)) ; Symbolic link
+                          (make-symbolic-link (car attrs) target t))
+                         (t
+                          (copy-file file target t keep-time)))))
+               dir-files))))
+
+        ;; Set directory attributes.
+        (set-file-modes newname (file-modes directory))
+        (if keep-time
+            (set-file-times newname (nth 5 (file-attributes directory)))))))
+
 \f
 (put 'revert-buffer-function 'permanent-local t)
 (defvar revert-buffer-function nil

-- 
A+ Thierry
Get my Gnupg key:
gpg --keyserver pgp.mit.edu --recv-keys 59F29997