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:
>>
>>> 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.
>>>>
>>>> It doesn't.
>>> Sorry, this one work now interactively and not.
>>
>> It still doesn't.
> It work here.
>
>> What do you think about testing yourself? I have given the recipe.
> Of course i did:
>
> ,----
> | - Create directory /tmp/test/test
> | - Create file /tmp/test/a
> | - Create file /tmp/test/test/b
> | 
> | - Apply (copy-directory "/tmp/test" "~/")
> |   Everything is fine
> | 
> | - Apply again (copy-directory "/tmp/test" "~/")
> |   The target directory structure is broken.
> `----
>
>
> ,----
> | - _Create the structure in /tmp_
> | 
> | (make-directory "/tmp/test")
> | nil
> | 
> | (make-directory "/tmp/test/test")
> | nil
> | 
> | (with-current-buffer (find-file-noselect "/tmp/test/a")
> |   (insert "test1")
> |   (save-buffer))
> | 
> | (with-current-buffer (find-file-noselect "/tmp/test/test/b")
> |   (insert "test2")
> |   (save-buffer))
> | 
> | (directory-files "/tmp/test")
> | ("." ".." "a" "test")
> | 
> | (directory-files "/tmp/test/test")
> | ("." ".." "b")
> | 
> | - _Copy the structure in ~/_
> | 
> | (copy-directory "/tmp/test" "~/")
> | nil
> | 
> | (directory-files "~/test")
> | ("." ".." "a" "test")
> | 
> | (directory-files "~/test/test")
> | ("." ".." "b")
> | 
> | - _Copy again the same structure in ~/ (Overwrite)_
> | 
> | (copy-directory "/tmp/test" "~/")
> | nil
> | 
> | (directory-files "~/test")
> | ("." ".." "a" "test")
> | 
> | (directory-files "~/test/test")
> | ("." ".." "b")
> `----
>
> As you can see the structure is always the same.
> Or did i miss something?

So here my last patch, well it's work fine here, i have tested with many
cases and the recipe above.

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

diff --git a/lisp/files.el b/lisp/files.el
index 4659742..a63a448 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,62 @@ 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)))
+                                   ;; Always allow recursive copy in non--interactive calls.
+                                   (not (interactive-p)))))
+            (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