From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Thierry Volpiatto Newsgroups: gmane.emacs.bugs Subject: bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy Date: Thu, 23 Feb 2012 23:10:18 +0100 Message-ID: <874nuhxktx.fsf@gmail.com> References: <87mx9su32g.fsf@web.de> <87vcodm8ns.fsf@gmx.de> <87pqekopb5.fsf@gmail.com> <87hazwoost.fsf@gmail.com> <87ty3w9639.fsf@gmx.de> <8762gckckt.fsf@gmail.com> <87pqek9269.fsf@gmx.de> <87r4z0yqfx.fsf@gmail.com> <871uqzn3bc.fsf@gmx.de> <871uqz651u.fsf@gmx.de> <87pqd89lh4.fsf@gmail.com> <87mx8b3nvb.fsf@gmail.com> <87pqd6wnvv.fsf@gmail.com> <87d395y1w0.fsf@gmail.com> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1330035163 17692 80.91.229.3 (23 Feb 2012 22:12:43 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Thu, 23 Feb 2012 22:12:43 +0000 (UTC) Cc: 10489@debbugs.gnu.org, Michael Albinus To: Stefan Monnier Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Thu Feb 23 23:12:42 2012 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([140.186.70.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1S0gu1-0006NR-UD for geb-bug-gnu-emacs@m.gmane.org; Thu, 23 Feb 2012 23:12:42 +0100 Original-Received: from localhost ([::1]:40497 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1S0gu0-0000BN-RG for geb-bug-gnu-emacs@m.gmane.org; Thu, 23 Feb 2012 17:12:40 -0500 Original-Received: from eggs.gnu.org ([140.186.70.92]:34683) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1S0gsw-0004pU-Cb for bug-gnu-emacs@gnu.org; Thu, 23 Feb 2012 17:11:35 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1S0gsu-0003PS-Oc for bug-gnu-emacs@gnu.org; Thu, 23 Feb 2012 17:11:34 -0500 Original-Received: from debbugs.gnu.org ([140.186.70.43]:49466) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1S0gsu-0003PO-LN for bug-gnu-emacs@gnu.org; Thu, 23 Feb 2012 17:11:32 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.72) (envelope-from ) id 1S0gvK-0007md-E8 for bug-gnu-emacs@gnu.org; Thu, 23 Feb 2012 17:14:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Thierry Volpiatto Original-Sender: debbugs-submit-bounces@debbugs.gnu.org Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Thu, 23 Feb 2012 22:14:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 10489 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 10489-submit@debbugs.gnu.org id=B10489.133003518329806 (code B ref 10489); Thu, 23 Feb 2012 22:14:02 +0000 Original-Received: (at 10489) by debbugs.gnu.org; 23 Feb 2012 22:13:03 +0000 Original-Received: from localhost ([127.0.0.1]:53089 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.72) (envelope-from ) id 1S0guM-0007kg-Mi for submit@debbugs.gnu.org; Thu, 23 Feb 2012 17:13:03 -0500 Original-Received: from mail-we0-f172.google.com ([74.125.82.172]:56380) by debbugs.gnu.org with esmtp (Exim 4.72) (envelope-from ) id 1S0guI-0007k5-OB for 10489@debbugs.gnu.org; Thu, 23 Feb 2012 17:13:00 -0500 Original-Received: by werg1 with SMTP id g1so1090882wer.3 for <10489@debbugs.gnu.org>; Thu, 23 Feb 2012 14:10:22 -0800 (PST) Received-SPF: pass (google.com: domain of thierry.volpiatto@gmail.com designates 10.180.86.230 as permitted sender) client-ip=10.180.86.230; Authentication-Results: mr.google.com; spf=pass (google.com: domain of thierry.volpiatto@gmail.com designates 10.180.86.230 as permitted sender) smtp.mail=thierry.volpiatto@gmail.com; dkim=pass header.i=thierry.volpiatto@gmail.com Original-Received: from mr.google.com ([10.180.86.230]) by 10.180.86.230 with SMTP id s6mr436585wiz.16.1330035022990 (num_hops = 1); Thu, 23 Feb 2012 14:10:22 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version:content-type; bh=FAT5+68DKxUJpQPqhNhxu7hvDPZ9jksftodE8WBhXns=; b=FyhxQhA3nPd2QYdIBb4/SXT0/YUXD07qe3VhomNBu7QQ3Fx9EoxAY030QQUnS8zWJr HfT7YTkv/u9DsHQMC6OsG20nDv2Y8XVrhMHvRqAk8DDrFLD65NUuEd1mfMS6A7SjRHRL FhRYXWoZquTkJUAmVio75LFsav8jsFojTSFh8= Original-Received: by 10.180.86.230 with SMTP id s6mr350928wiz.16.1330035022920; Thu, 23 Feb 2012 14:10:22 -0800 (PST) Original-Received: from thierry-MM061 (lbe83-2-78-243-104-167.fbx.proxad.net. [78.243.104.167]) by mx.google.com with ESMTPS id fw5sm7159757wib.0.2012.02.23.14.10.20 (version=TLSv1/SSLv3 cipher=OTHER); Thu, 23 Feb 2012 14:10:21 -0800 (PST) In-Reply-To: (Stefan Monnier's message of "Thu, 23 Feb 2012 12:18:51 -0500") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.0.93 (gnu/linux) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.13 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 2) X-Received-From: 140.186.70.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.bugs:57152 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Stefan Monnier writes: >> Here a first shot of `copy-directory', with the first check disabled >> (file-subdir-of-p) to test the detection of the inf-loop, can you have a >> look? > > I think we can install the file-subdir-of-p test now and leave the rest > for 24.2. Can you (re)send the corresponding patch? Note that > (or (files-equal-p directory newname) > (file-subdir-of-p newname directory)) > should be replaced by just (file-subdir-of-p newname directory), because > this primitive should be a "=E2=8A=86" rather than "=E2=8A=82". Done, you should have received the patch.=20 > > I always prefer a patch rather than the resulting code, so I don't have > to look for the source code to see what's changed. Ok, here the patch for only `copy-directory' with the check by `file-subdir-of-p' disabled for testing purpose. --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=Singlepatch-r118952ToTip.patch Content-Description: copy-directory ##Merge of all patches applied from revision 118951 ## patch-r118952: Return Error when trying to copy a directory on itself. ## patch-r118953: * lisp/files.el (copy-directory): Improve error message. ## diff --git a/lisp/files.el b/lisp/files.el --- a/lisp/files.el +++ b/lisp/files.el @@ -4935,6 +4935,7 @@ (equal (file-attributes (file-truename root)) (file-attributes f2)))))) +(defvar copy-directory-newdir-inode nil) (defun copy-directory (directory newname &optional keep-time parents copy-contents) "Copy DIRECTORY to NEWNAME. Both args must be strings. This function always sets the file modes of the output files to match @@ -4961,54 +4962,63 @@ (format "Copy directory %s to: " dir) default-directory default-directory nil nil) current-prefix-arg t nil))) - (when (file-subdir-of-p newname directory) - (error "Can't copy directory `%s' on itself" directory)) + ;; (when (file-subdir-of-p newname directory) + ;; (error "Can't copy directory `%s' on itself" directory)) ;; 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))) - - (cond ((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 and COPY-CONTENTS - ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME]. - ((not copy-contents) - (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. - (let ((modes (file-modes directory)) - (times (and keep-time (nth 5 (file-attributes directory))))) - (if modes (set-file-modes newname modes)) - (if times (set-file-times newname times)))))) + (unwind-protect + (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 (file-truename (directory-file-name (expand-file-name directory))) + newname (file-truename (directory-file-name (expand-file-name newname)))) + (cond ((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 and COPY-CONTENTS + ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME]. + ((not copy-contents) + (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) + (unless copy-directory-newdir-inode + (setq copy-directory-newdir-inode (nth 10 (file-attributes newname)))))) + + ;; Copy recursively. + (dolist (file + ;; We do not want to copy "." and "..". + (directory-files directory 'full + directory-files-no-dot-files-regexp)) + (assert (not (equal (nth 10 (file-attributes file)) + copy-directory-newdir-inode)) + nil "Unable to create directory `%s' in itself `%s'" + (file-name-nondirectory (directory-file-name file)) + (file-name-directory (directory-file-name newname))) + (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. + (let ((modes (file-modes directory)) + (times (and keep-time (nth 5 (file-attributes directory))))) + (if modes (set-file-modes newname modes)) + (if times (set-file-times newname times))))) + (setq copy-directory-newdir-inode nil))) (put 'revert-buffer-function 'permanent-local t) (defvar revert-buffer-function nil --=-=-= Content-Type: text/plain -- Thierry Get my Gnupg key: gpg --keyserver pgp.mit.edu --recv-keys 59F29997 --=-=-=--