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:
>>
>>> What we could do also is create a function copy-directory-contents, that
>>> reuse the code of precedent version of copy-directory (but not
>>> interactive this time) and call this function in
>>> dired-copy-file-recursive instead of copy-directory.
>>>
>>> In this case we could rewrite copy-directory to avoid duplicate code,
>>> possibly: (no urge in this case as actual copy-directory works fine) 
>>>
>>> 1) Writing copy-directory-contents (or whatever name) to allow
>>> creating the structure like actual copy-directory, or not like ancient
>>> version leaving this job to dired-create-files.
>>>
>>> 2) Writing a copy-directory that reuse dired code (i.e dired-create-files).
>>> In this case it would have all interactive messages, ask etc..
>>>
>>> WDYT?
>>
>> I would prefer option 2). There is no need to have an extra dired
>> implementation, now we have copy-directory.
>
> So i made first steps:
>
> - Create new function copy-directory-contents based on old
> copy-directory code.
>
> - Use it in dired-copy-file-recursive instead of copy-directory.
>
> Seems to work fine.
There was an error though.

Now the last fix. (sent to Chong)
I think that's correct:
Use a new function copy-directory1 that can be reused by copy-directory,
avoiding duplicate code.
This function use an extra arg `create-struct'.
When this arg is used copy-directory1 works like actual copy-directory.
Otherwise it does like before and doesn't break dired.
As i am using dired code in anything, i have inlined this changes in
anything-config.el waiting this patch is applied or maybe another fix if
you have better idea.
Thanks Michael and Chong.

Here the patch:

---
 lisp/dired-aux.el |    2 +-
 lisp/files.el     |   98 ++++++++++++++++++++++++++++-------------------------
 2 files changed, 53 insertions(+), 47 deletions(-)

diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 28b285f..b26ce0a 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1242,7 +1242,7 @@ Special value `always' suppresses confirmation."
 	     (or (eq recursive 'always)
 		 (yes-or-no-p (format "Recursive copies of %s? " from))))
 	;; This is a directory.
-	(copy-directory from to dired-copy-preserve-time)
+	(copy-directory1 from to dired-copy-preserve-time)
       ;; Not a directory.
       (or top (dired-handle-overwrite to))
       (condition-case err
diff --git a/lisp/files.el b/lisp/files.el
index d896020..c75a330 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4723,7 +4723,56 @@ 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)
+(defun copy-directory1 (directory newname &optional keep-time parents create-struct)
+  ;; 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))))
+    (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].
+            (when create-struct
+              (setq newname (expand-file-name
+                             (file-name-nondirectory
+                              (directory-file-name directory))
+                             newname))
+              (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.
+        (dolist (file
+                  ;; We do not want to copy "." and "..".
+                  (directory-files directory 'full
+                                   directory-files-no-dot-files-regexp))
+          (let ((target (expand-file-name (file-name-nondirectory file) newname))
+                (attrs (file-attributes file)))
+            (cond ((and (file-directory-p file) create-struct)
+                   (copy-directory1 file newname keep-time parents create-struct))
+                  ((file-directory-p file)
+                   (copy-directory1 file target keep-time parents create-struct))
+                  ((stringp (car attrs)) ; Symbolic link
+                   (make-symbolic-link (car attrs) target t))
+                  (t (copy-file file target t keep-time)))))
+
+        ;; Set directory attributes.
+        (set-file-modes newname (file-modes directory))
+        (when keep-time
+          (set-file-times newname (nth 5 (file-attributes directory)))))))
+
+(defun copy-directory (directory newname &optional keep-time parents create-struct)
   "Copy DIRECTORY to NEWNAME.  Both args must be strings.
 If NEWNAME names an existing directory, copy DIRECTORY as subdirectory there.
 
@@ -4745,51 +4794,8 @@ this happens by default."
 	   (read-file-name
 	    (format "Copy directory %s to: " dir)
 	    default-directory default-directory nil nil)
-	   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))))
-    (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))
-	(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.
-      (dolist (file
-	       ;; We do not want to copy "." and "..".
-	       (directory-files directory 'full
-				directory-files-no-dot-files-regexp))
-	(if (file-directory-p file)
-	    (copy-directory file newname keep-time parents)
-	  (let ((target (expand-file-name (file-name-nondirectory file) newname))
-		(attrs (file-attributes file)))
-	    (if (stringp (car attrs)) ; Symbolic link
-		(make-symbolic-link (car attrs) target t)
-	      (copy-file file target t keep-time)))))
-
-      ;; Set directory attributes.
-      (set-file-modes newname (file-modes directory))
-      (if keep-time
-	  (set-file-times newname (nth 5 (file-attributes directory)))))))
+	   current-prefix-arg t t)))
+  (copy-directory1 directory newname keep-time parents create-struct))
 \f
 (put 'revert-buffer-function 'permanent-local t)
 (defvar revert-buffer-function nil
-- 
1.7.1



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