Re: bug in copy-directory

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

Michael Albinus <michael.albinus@gmx.de> writes:

> Thierry Volpiatto <thierry.volpiatto@gmail.com> writes:
>
>>> 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.
>
> I doesn't.
Sorry, this one work now interactively and not.

---
 lisp/files.el |   98 ++++++++++++++++++++++++++++++++-------------------------
 1 files changed, 55 insertions(+), 43 deletions(-)

diff --git a/lisp/files.el b/lisp/files.el
index 4659742..464f00a 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,61 @@ 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)))))))
+        (funcall handler 'copy-directory directory newname keep-time parents)
+        ;; Else Compute target name.
+        (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)
+            (if (interactive-p)
+                (if (y-or-n-p (format "Directory `%s' exists, overwrite? "
+                                      newname))
+                    (progn
+                      (delete-directory newname t)
+                      (make-directory newname 'parents))
+                    (error "Abort copying directory"))
+                (delete-directory newname t)
+                (make-directory newname 'parents))
+            (if (file-exists-p newname)
+                (error "Cannot overwrite non-directory %s with a directory"
+                       newname)
+                (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))
+        (when 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