From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Thierry Volpiatto Newsgroups: gmane.emacs.devel Subject: Re: bug in copy-directory Date: Sun, 30 Jan 2011 22:18:29 +0100 Message-ID: <87tygqnl96.fsf@gmail.com> References: <87ipxaidea.fsf@gmail.com> <87k4hp96g0.fsf@stupidchicken.com> <878vy59ejz.fsf@stupidchicken.com> <87lj23ickn.fsf@stupidchicken.com> <87sjway8i3.fsf@gmx.de> <87bp2yts8m.fsf@gmail.com> <87fwsaxyy0.fsf@gmx.de> <87y662sbjs.fsf@gmail.com> <87k4hmpgdf.fsf@gmail.com> <874o8qs2xj.fsf@gmx.de> <87bp2yp8nk.fsf@gmail.com> <87zkqiqlwn.fsf@gmx.de> <87y662nrbh.fsf@gmail.com> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: dough.gmane.org 1296422336 19408 80.91.229.12 (30 Jan 2011 21:18:56 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 30 Jan 2011 21:18:56 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Sun Jan 30 22:18:51 2011 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1PjefZ-0000FZ-NW for ged-emacs-devel@m.gmane.org; Sun, 30 Jan 2011 22:18:50 +0100 Original-Received: from localhost ([127.0.0.1]:36092 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PjefZ-0004yS-1B for ged-emacs-devel@m.gmane.org; Sun, 30 Jan 2011 16:18:49 -0500 Original-Received: from [140.186.70.92] (port=35339 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PjefT-0004yH-SH for emacs-devel@gnu.org; Sun, 30 Jan 2011 16:18:45 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PjefS-0001we-Ez for emacs-devel@gnu.org; Sun, 30 Jan 2011 16:18:43 -0500 Original-Received: from lo.gmane.org ([80.91.229.12]:42288) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1PjefR-0001w2-U2 for emacs-devel@gnu.org; Sun, 30 Jan 2011 16:18:42 -0500 Original-Received: from list by lo.gmane.org with local (Exim 4.69) (envelope-from ) id 1PjefQ-00008p-8E for emacs-devel@gnu.org; Sun, 30 Jan 2011 22:18:40 +0100 Original-Received: from 63.211.85-79.rev.gaoland.net ([79.85.211.63]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Sun, 30 Jan 2011 22:18:40 +0100 Original-Received: from thierry.volpiatto by 63.211.85-79.rev.gaoland.net with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Sun, 30 Jan 2011 22:18:40 +0100 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 215 Original-X-Complaints-To: usenet@dough.gmane.org X-Gmane-NNTP-Posting-Host: 63.211.85-79.rev.gaoland.net User-Agent: Gnus/5.110011 (No Gnus v0.11) Emacs/23.2.92 (gnu/linux) Cancel-Lock: sha1:uCs/xgcZX64DNKSW5jBG2xd9eXE= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-Received-From: 80.91.229.12 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:135259 Archived-At: Thierry Volpiatto writes: > Michael Albinus writes: > >> Thierry Volpiatto writes: >> >>> Michael Albinus writes: >>> >>>> Thierry Volpiatto 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