From: thierry volpiatto Date: Fri, 24 Feb 2012 18:04:03 +0000 (+0100) Subject: Fix bug#10489: 24.0.92 `dired-do-copy' may create infinite directory hierarchy. X-Git-Url: http://git.hcoop.net/bpt/emacs.git/commitdiff_plain/25b2e303b07ba9b68c2749754c6cca88f0ecac91 Fix bug#10489: 24.0.92 `dired-do-copy' may create infinite directory hierarchy. * lisp/files.el (files-equal-p): New, simple equality check between two filename. (file-subdir-of-p): New, Check if dir1 is subdir of dir2. (copy-directory): Return error when trying to copy a directory on itself. Add missing copy-contents arg to tramp handler. * lisp/dired-aux.el (dired-copy-file-recursive): Same. (dired-create-files): Modify destination when source is equal to dest when copying files. Return also when dest is a subdir of source. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 46d8ca44a0..b019820fe9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2012-02-24 Thierry Volpiatto + + * lisp/files.el (files-equal-p): New, simple equality check between two filename. + (file-subdir-of-p): New, Check if dir1 is subdir of dir2. + (copy-directory): Return error when trying to copy a directory on itself. + Add missing copy-contents arg to tramp handler. + + * lisp/dired-aux.el (dired-copy-file-recursive): Same. + (dired-create-files): Modify destination when source is equal to dest when copying files. + Return also when dest is a subdir of source. + (bug#10489) + 2012-02-24 Michael Albinus * net/ange-ftp.el (ange-ftp-parse-netrc): Suppress comment lines. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 2d05be312e..d6a4a7816d 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1264,6 +1264,8 @@ Special value `always' suppresses confirmation." (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) + (when (file-subdir-of-p to from) + (error "Cannot copy `%s' into its subdirectory `%s'" from to)) (let ((attrs (file-attributes from))) (if (and recursive (eq t (car attrs)) @@ -1430,10 +1432,30 @@ ESC or `q' to not overwrite any of the remaining files, (cond ((integerp marker-char) marker-char) (marker-char (dired-file-marker from)) ; slow (t nil)))) - (when (and (file-directory-p from) - (file-directory-p to) - (eq file-creator 'dired-copy-file)) - (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 or one of its subdirectories. + ;; e.g "~/foo/" => "~/test/" + ;; or "~/foo/" =>"~/foo/" + ;; or "~/foo/ => ~/foo/bar/") + ;; In this case the 'name-constructor' have set the destination + ;; TO to "~/test/foo" because the old emacs23 behavior + ;; of `copy-directory' was to not create the subdirectory + ;; and instead copy the contents. + ;; With the new behavior of `copy-directory' + ;; (similar to the `cp' shell command) we don't + ;; need such a construction of the target directory, + ;; so modify the destination TO to "~/test/" instead of "~/test/foo/". + (let ((destname (file-name-directory to))) + (when (and (file-directory-p from) + (file-directory-p to) + (eq file-creator 'dired-copy-file)) + (setq to destname)) + ;; If DESTNAME and FROM are the same directory or + ;; If DESTNAME is a subdirectory of FROM, return error. + (and (file-subdir-of-p destname from) + (error "Cannot copy `%s' into its subdirectory `%s'" + from to))) (condition-case err (progn (funcall file-creator from to dired-overwrite-confirmed) diff --git a/lisp/files.el b/lisp/files.el index 87218c9a6e..089f248b2a 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -4985,6 +4985,39 @@ given. With a prefix argument, TRASH is nil." directory 'full directory-files-no-dot-files-regexp))) (delete-directory-internal directory))))) +(defun files-equal-p (file1 file2) + "Return non-nil if FILE1 and FILE2 name the same file." + (let ((handler (or (find-file-name-handler file1 'files-equal-p) + (find-file-name-handler file2 'files-equal-p)))) + (if handler + (funcall handler 'files-equal-p file1 file2) + (equal (file-attributes (file-truename file1)) + (file-attributes (file-truename file2)))))) + +(defun file-subdir-of-p (dir1 dir2) + "Return non-nil if DIR1 is a subdirectory of DIR2. +Note that a directory is treated by this function as a subdirectory of itself. +This function only works when its two arguments already exist, +when they don't, it returns nil." + (let ((handler (or (find-file-name-handler dir1 'file-subdir-of-p) + (find-file-name-handler dir2 'file-subdir-of-p)))) + (if handler + (funcalll handler 'file-subdir-of-p dir1 dir2) + (when (and (file-directory-p dir1) + (file-directory-p dir2)) + (loop with f1 = (file-truename dir1) + with f2 = (file-truename dir2) + with ls1 = (or (split-string f1 "/" t) (list "/")) + with ls2 = (or (split-string f2 "/" t) (list "/")) + for p = (string-match "^/" f1) + for i in ls1 + for j in ls2 + when (string= i j) + concat (if p (concat "/" i) (concat i "/")) + into root + finally return + (files-equal-p (file-truename root) 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 @@ -5011,12 +5044,16 @@ directly into NEWNAME instead." (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 "Cannot copy `%s' into its subdirectory `%s'" + directory newname)) ;; 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) + (funcall handler 'copy-directory directory + newname keep-time parents copy-contents) ;; Compute target name. (setq directory (directory-file-name (expand-file-name directory)) @@ -5025,7 +5062,12 @@ directly into NEWNAME instead." (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)) + (make-directory newname parents) + ;; `file-subdir-of-p' doesn't handle non--existing directories, + ;; so double check now if NEWNAME is not a subdir of DIRECTORY. + (and (file-subdir-of-p newname directory) + (error "Cannot copy `%s' into its subdirectory `%s'" + directory newname))) ;; If NEWNAME is an existing directory and COPY-CONTENTS ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME]. ((not copy-contents)