[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: bug in copy-directory
From: |
Thierry Volpiatto |
Subject: |
Re: bug in copy-directory |
Date: |
Sun, 30 Jan 2011 22:18:29 +0100 |
User-agent: |
Gnus/5.110011 (No Gnus v0.11) Emacs/23.2.92 (gnu/linux) |
Thierry Volpiatto <address@hidden> writes:
> Michael Albinus <address@hidden> writes:
>
>> Thierry Volpiatto <address@hidden> writes:
>>
>>> Michael Albinus <address@hidden> writes:
>>>
>>>> Thierry Volpiatto <address@hidden> 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)))))))
+
(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
- Re: bug in copy-directory, (continued)
- Re: bug in copy-directory, Thierry Volpiatto, 2011/01/30
- Re: bug in copy-directory, Michael Albinus, 2011/01/30
- Re: bug in copy-directory, Thierry Volpiatto, 2011/01/30
- Re: bug in copy-directory, Thierry Volpiatto, 2011/01/30
- Re: bug in copy-directory, Thierry Volpiatto, 2011/01/30
- Re: bug in copy-directory, Michael Albinus, 2011/01/30
- Re: bug in copy-directory, Thierry Volpiatto, 2011/01/30
- Re: bug in copy-directory, Thierry Volpiatto, 2011/01/30
- Re: bug in copy-directory, Michael Albinus, 2011/01/30
- Re: bug in copy-directory, Thierry Volpiatto, 2011/01/30
- Re: bug in copy-directory,
Thierry Volpiatto <=
- Re: bug in copy-directory, Chong Yidong, 2011/01/31