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 19:07:43 +0100 Message-ID: <87bp2yp8nk.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> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: dough.gmane.org 1296410878 30382 80.91.229.12 (30 Jan 2011 18:07:58 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 30 Jan 2011 18:07:58 +0000 (UTC) Cc: emacs-devel@gnu.org To: Michael Albinus Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Sun Jan 30 19:07:53 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 1Pjbgn-0005Qu-Gy for ged-emacs-devel@m.gmane.org; Sun, 30 Jan 2011 19:07:53 +0100 Original-Received: from localhost ([127.0.0.1]:37104 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Pjbgm-0000UC-Mf for ged-emacs-devel@m.gmane.org; Sun, 30 Jan 2011 13:07:52 -0500 Original-Received: from [140.186.70.92] (port=43030 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Pjbgi-0000Tr-Ap for emacs-devel@gnu.org; Sun, 30 Jan 2011 13:07:49 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Pjbgg-0000zD-Tf for emacs-devel@gnu.org; Sun, 30 Jan 2011 13:07:48 -0500 Original-Received: from mail-ww0-f49.google.com ([74.125.82.49]:50088) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Pjbgg-0000z9-Ki for emacs-devel@gnu.org; Sun, 30 Jan 2011 13:07:46 -0500 Original-Received: by wwb17 with SMTP id 17so5220106wwb.30 for ; Sun, 30 Jan 2011 10:07:46 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma; h=domainkey-signature:from:to:cc:subject:references:date:in-reply-to :message-id:user-agent:mime-version:content-type; bh=syhY4T+1nONJ5XG69mKr6qcjCC3VNbj+tQ7uGiSK2iQ=; b=hc42oPj+MyljA3RYhKc6MhiE6mErNHZTm5SgWtO8mbY5Xw/cyYEuVjyyYeQ6BKr1Y+ WYVMYHmgTNQaoUY4Ha4wcOx0M3OkliDMKXUfimQ/Y8AjeOxRVsTt0XS5miXgUhR7OILA e9+OdIpDA/xqIkdBFuqI1aZqjvjUHoLaWHGRI= DomainKey-Signature: a=rsa-sha1; c=nofws; d=gmail.com; s=gamma; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version:content-type; b=fPOWg/1/Qpko2t7Va5K941nvs0iOySWKgqD4G/YLnrB/1uKnyAO8PFL9TXg1AHagrQ VhymHbiBdGqR4XHOEBVC/GJdCglHhFkGVIkc8V9hlEHedDvsUaX71YTz3tuEfmZfG1Tv CfySwcnw6t+C6PNYc5uShFsCnzArO+Uo43Yok= Original-Received: by 10.216.254.89 with SMTP id g67mr9926873wes.7.1296410865881; Sun, 30 Jan 2011 10:07:45 -0800 (PST) Original-Received: from thierry-MM061 (63.211.85-79.rev.gaoland.net [79.85.211.63]) by mx.google.com with ESMTPS id n11sm10310077wej.19.2011.01.30.10.07.44 (version=TLSv1/SSLv3 cipher=RC4-MD5); Sun, 30 Jan 2011 10:07:45 -0800 (PST) In-Reply-To: <874o8qs2xj.fsf@gmx.de> (Michael Albinus's message of "Sun, 30 Jan 2011 18:43:04 +0100") User-Agent: Gnus/5.110011 (No Gnus v0.11) Emacs/23.2.92 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 2) X-Received-From: 74.125.82.49 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:135250 Archived-At: 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. > > 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))))))) + (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