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: Sat, 21 Jan 2012 17:02:46 +0100 Message-ID: <87sjj9jb6h.fsf@gmail.com> References: <87mx9su32g.fsf@web.de> <87fwfjsw8t.fsf@gmail.com> <87aa5rdazl.fsf@gmx.de> <87d3anogf5.fsf@gmail.com> <011AEED9E81C4DEFA6B1E03B0F57F28F@us.oracle.com> <878vlbljnc.fsf@gmx.de> <8739bj8mu1.fsf@gmail.com> <87fwfjo24c.fsf@gmx.de> <87pqen76p4.fsf@gmail.com> <83fwfik92e.fsf@gnu.org> <87mx9q1sz7.fsf@gmail.com> <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> <87ehuti507.fsf@gmail.com> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" X-Trace: dough.gmane.org 1327161852 3094 80.91.229.12 (21 Jan 2012 16:04:12 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sat, 21 Jan 2012 16:04:12 +0000 (UTC) To: 10489@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Sat Jan 21 17:04:08 2012 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([140.186.70.17]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1RodQC-0003xB-Od for geb-bug-gnu-emacs@m.gmane.org; Sat, 21 Jan 2012 17:04:05 +0100 Original-Received: from localhost ([::1]:35068 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RodQC-0006d6-BX for geb-bug-gnu-emacs@m.gmane.org; Sat, 21 Jan 2012 11:04:04 -0500 Original-Received: from eggs.gnu.org ([140.186.70.92]:47273) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RodQ8-0006ct-AH for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 11:04:01 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1RodQ6-0003tD-On for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 11:04:00 -0500 Original-Received: from debbugs.gnu.org ([140.186.70.43]:33875) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RodQ6-0003t9-M1 for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 11:03:58 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.72) (envelope-from ) id 1RodQA-0006AQ-0i for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 11:04:02 -0500 X-Loop: help-debbugs@gnu.org In-Reply-To: <87mx9su32g.fsf@web.de> Resent-From: Thierry Volpiatto Original-Sender: debbugs-submit-bounces@debbugs.gnu.org Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 21 Jan 2012 16:04:01 +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 X-Debbugs-Original-To: bug-gnu-emacs@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.132716182323668 (code B ref -1); Sat, 21 Jan 2012 16:04:01 +0000 Original-Received: (at submit) by debbugs.gnu.org; 21 Jan 2012 16:03:43 +0000 Original-Received: from localhost ([127.0.0.1]:39259 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.72) (envelope-from ) id 1RodPq-00069h-LN for submit@debbugs.gnu.org; Sat, 21 Jan 2012 11:03:43 -0500 Original-Received: from eggs.gnu.org ([140.186.70.92]:46151) by debbugs.gnu.org with esmtp (Exim 4.72) (envelope-from ) id 1RodPl-00069Q-LT for submit@debbugs.gnu.org; Sat, 21 Jan 2012 11:03:40 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1RodPb-0003pa-B4 for submit@debbugs.gnu.org; Sat, 21 Jan 2012 11:03:28 -0500 Original-Received: from lists.gnu.org ([140.186.70.17]:40183) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RodPb-0003pW-9V for submit@debbugs.gnu.org; Sat, 21 Jan 2012 11:03:27 -0500 Original-Received: from eggs.gnu.org ([140.186.70.92]:47138) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RodPZ-0006Z9-OO for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 11:03:27 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1RodPK-0003nk-J8 for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 11:03:25 -0500 Original-Received: from lo.gmane.org ([80.91.229.12]:45521) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RodPJ-0003nN-MX for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 11:03:10 -0500 Original-Received: from list by lo.gmane.org with local (Exim 4.69) (envelope-from ) id 1RodPI-0003X2-9V for bug-gnu-emacs@gnu.org; Sat, 21 Jan 2012 17:03:08 +0100 Original-Received: from 204.77.197.77.rev.sfr.net ([77.197.77.204]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Sat, 21 Jan 2012 17:03:08 +0100 Original-Received: from thierry.volpiatto by 204.77.197.77.rev.sfr.net with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Sat, 21 Jan 2012 17:03:08 +0100 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 245 Original-X-Complaints-To: usenet@dough.gmane.org X-Gmane-NNTP-Posting-Host: 204.77.197.77.rev.sfr.net User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.0.92 (gnu/linux) Cancel-Lock: sha1:r4OnbiQ4bg2mQcnMQ/o69tt7SHw= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) 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:55893 Archived-At: --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain Content-Transfer-Encoding: quoted-printable Thierry Volpiatto writes: > Andreas Schwab writes: > >>> So, any objections to apply my patch to trunk with these changes? >> >> You also need to check whether the target is a subdirectory of the >> source. Sorry the last patch sent haven't the last changes included. Here the good one. =2D-=20 Thierry Get my Gnupg key: gpg --keyserver pgp.mit.edu --recv-keys 59F29997=20 --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=Singlepatch-r118414ToTip.patch Content-Transfer-Encoding: quoted-printable ##Merge of all patches applied from revision 118409 ## patch-r118414: Bugfix bug#10489, dired-do-copy may create infinite direc= tory hierarchy. ## patch-r118411: * lisp/dired-aux.el (dired-copy-file-recursive): Use file= -equal-p. ## patch-r118412: * lisp/files.el (file-subdir-of-p): Check if file1 is sub= dir of file2. ##=20 diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el =2D-- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1264,24 +1264,27 @@ =20 (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) + (when (or (files-equal-p from to) + (file-subdir-of-p to from)) + (error "Can't copy directory `%s' on itself" from)) (let ((attrs (file-attributes from))) (if (and recursive =2D (eq t (car attrs)) =2D (or (eq recursive 'always) =2D (yes-or-no-p (format "Recursive copies of %s? " from)))) =2D ;; This is a directory. =2D (copy-directory from to preserve-time) + (eq t (car attrs)) + (or (eq recursive 'always) + (yes-or-no-p (format "Recursive copies of %s? " from)))) + ;; This is a directory. + (copy-directory from to preserve-time) ;; Not a directory. (or top (dired-handle-overwrite to)) (condition-case err =2D (if (stringp (car attrs)) =2D ;; It is a symlink =2D (make-symbolic-link (car attrs) to ok-flag) =2D (copy-file from to ok-flag preserve-time)) =2D (file-date-error =2D (push (dired-make-relative from) =2D dired-create-files-failures) =2D (dired-log "Can't set date on %s:\n%s\n" from err)))))) + (if (stringp (car attrs)) + ;; It is a symlink + (make-symbolic-link (car attrs) to ok-flag) + (copy-file from to ok-flag preserve-time)) + (file-date-error + (push (dired-make-relative from) + dired-create-files-failures) + (dired-log "Can't set date on %s:\n%s\n" from err)))))) =20 ;;;###autoload (defun dired-rename-file (file newname ok-if-already-exists) @@ -1378,7 +1381,7 @@ =20 ;; The basic function for half a dozen variations on cp/mv/ln/ln -s. (defun dired-create-files (file-creator operation fn-list name-constructor =2D &optional marker-char) + &optional marker-char) "Create one or more new files from a list of existing files FN-LIST. This function also handles querying the user, updating Dired buffers, and displaying a success or failure message. @@ -1401,10 +1404,14 @@ Optional MARKER-CHAR is a character with which to mark every newfile's entry, or t to use the current marker character if the old file was marked." =2D (let (dired-create-files-failures failures =2D skipped (success-count 0) (total (length fn-list))) =2D (let (to overwrite-query =2D overwrite-backup-query) ; for dired-handle-overwrite + (let (dired-create-files-failures + failures + skipped + (success-count 0) + (total (length fn-list))) + (let (to + overwrite-query + overwrite-backup-query) ; for dired-handle-overwrite (dolist (from fn-list) (setq to (funcall name-constructor from)) (if (equal to from) @@ -1430,10 +1437,27 @@ (cond ((integerp marker-char) marker-char) (marker-char (dired-file-marker from)) ; slow (t nil)))) =2D (when (and (file-directory-p from) =2D (file-directory-p to) =2D (eq file-creator 'dired-copy-file)) =2D (setq to (file-name-directory to))) + ;; Handle the `dired-copy-file' file-creator specially + ;; When copying a directory to another directory or + ;; possibly to itself. + ;; (e.g "~/foo" =3D> "~/test" or "~/foo" =3D>"~/foo") + ;; In this case the 'name-constructor' have set the destination + ;; 'to' to "~/test/foo" because the old + ;; emacs23 behavior of `copy-directory' + ;; was no not create the subdir and copy instead the contents = only. + ;; With it's new behavior (similar to cp shell command) we don= 't + ;; need such a construction, so modify the destination 'to' to + ;; "~/test/" instead of "~/test/foo/". + ;; If from and to are the same directory do the same, + ;; the error will be handled by `dired-copy-file-recursive'. + (let ((destname (file-name-directory to))) + (when (and (file-directory-p from) + (or (files-equal-p from destname) + (file-directory-p to)) + (eq file-creator 'dired-copy-file)) + (setq to destname)) + (and (file-subdir-of-p destname from) + (error "Can't copy directory `%s' on itself" from))) (condition-case err (progn (funcall file-creator from to dired-overwrite-confirmed) @@ -1456,25 +1480,25 @@ (setq failures (nconc failures dired-create-files-failures)) (dired-log-summary (format "%s failed for %d file%s in %d requests" =2D operation (length failures) =2D (dired-plural-s (length failures)) =2D total) + operation (length failures) + (dired-plural-s (length failures)) + total) failures)) (failures (dired-log-summary (format "%s failed for %d of %d file%s" =2D operation (length failures) =2D total (dired-plural-s total)) + operation (length failures) + total (dired-plural-s total)) failures)) (skipped (dired-log-summary (format "%s: %d of %d file%s skipped" =2D operation (length skipped) total =2D (dired-plural-s total)) + operation (length skipped) total + (dired-plural-s total)) skipped)) (t (message "%s: %s file%s" =2D operation success-count (dired-plural-s success-count))))) + operation success-count (dired-plural-s success-count))))) (dired-move-to-filename)) (defun dired-do-create-files (op-symbol file-creator operation arg diff --git a/lisp/files.el b/lisp/files.el =2D-- a/lisp/files.el +++ b/lisp/files.el @@ -4902,6 +4902,35 @@ directory 'full directory-files-no-dot-files-regexp))) (delete-directory-internal directory))))) =20 +(defun files-equal-p (file1 file2) + "Return non-nil if FILE1 and FILE2 name the same file." + (and (equal (file-remote-p file1) (file-remote-p file2)) + (equal (file-attributes (file-truename (expand-file-name file1))) + (file-attributes (file-truename (expand-file-name file2)))))) + +(defun file-subdir-of-p (file1 file2) + "Check if FILE1 is a subdirectory of FILE2 on current filesystem. +If directory FILE1 is the same than directory FILE2, return non--nil." + (when (and (not (or (file-remote-p file1) + (file-remote-p file2))) + (not (string=3D file1 "/")) + (file-directory-p file1) + (file-directory-p file2)) + (or (string=3D file2 "/") + (loop with f1 =3D (expand-file-name file1) + with f2 =3D (expand-file-name file2) + with ls1 =3D (split-string f1 "/" t) + with ls2 =3D (split-string f2 "/" t) + for p =3D (string-match "^/" f1) + for i in ls1 + for j in ls2 + when (string=3D i j) + concat (if p (concat "/" i) (concat i "/")) + into root + finally return + (string=3D (file-truename (directory-file-name root)) + (file-truename (directory-file-name f2))))))) + (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 @@ -4928,10 +4957,13 @@ (format "Copy directory %s to: " dir) default-directory default-directory nil nil) current-prefix-arg t nil))) + (when (or (files-equal-p directory newname) + (file-subdir-of-p directory newname)) + (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) =2D (find-file-name-handler newname 'copy-directory)))) + (find-file-name-handler newname 'copy-directory)))) (if handler (funcall handler 'copy-directory directory newname keep-time parents) =20 --=-=-=-- --==-=-= Content-Type: application/pgp-signature -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.11 (GNU/Linux) iEYEARECAAYFAk8a4aYACgkQKNF/U1nymZcRvgCfaJ5DJ15gbJ7HM7iCqLPtap+S XXIAoIhL072YOh/Qtfop/xgSPRsdecZw =07qE -----END PGP SIGNATURE----- --==-=-=--