GNU bug report logs -
#10489
24.0.92; dired-do-copy may create infinite directory hierarchy
Previous Next
Reported by: michael_heerdegen <at> web.de
Date: Thu, 12 Jan 2012 19:36:01 UTC
Severity: important
Tags: patch
Merged with 11130
Found in version 24.0.92
Done: Chong Yidong <cyd <at> gnu.org>
Bug is archived. No further changes may be made.
Full log
Message #264 received at submit <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Thierry Volpiatto <thierry.volpiatto <at> gmail.com> writes:
> Stefan Monnier <monnier <at> iro.umontreal.ca> writes:
>
>> 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 "⊆" rather than "⊂".
>
> I have removed one more occurence of `files-equal-p' no more needed in
> dired-aux.el.
> So this function is not needed actually; I have not removed it though.
> Maybe I should and add it only after 24.1?
Just realize that this match was quite old.
I have merged this patch with last revision of today.
So ignore precedent and review this one.
I it's ok I will apply it on trunk.
[patch-r118916.patch (text/x-diff, inline)]
# HG changeset patch
# User Thierry Volpiatto <thierry.volpiatto <at> gmail.com>
# Date 1330067166 -3600
# Node ID 71a95b366b8509169d01466c44f01c1bcd96d4f7
# Parent d736ca342d20302be2fcb7e81f1c9e364b759663
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 file1 is subdir of file2.
(copy-directory): Return error when trying to copy a directory on itself.
* 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/dired-aux.el b/lisp/dired-aux.el
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1264,6 +1264,8 @@
(defun dired-copy-file-recursive (from to ok-flag &optional
preserve-time top recursive)
+ (when (file-subdir-of-p to from)
+ (error "Can't copy directory `%s' on itself" from))
(let ((attrs (file-attributes from)))
(if (and recursive
(eq t (car attrs))
@@ -1430,10 +1432,26 @@
(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.
+ ;; (e.g "~/foo" => "~/test" or "~/foo" =>"~/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)
+ (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)
diff --git a/lisp/files.el b/lisp/files.el
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4985,6 +4985,35 @@
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."
+ (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= file1 "/"))
+ (file-directory-p file1)
+ (file-directory-p file2))
+ (or (string= file2 "/")
+ (loop with f1 = (expand-file-name (file-truename file1))
+ with f2 = (expand-file-name (file-truename file2))
+ with ls1 = (split-string f1 "/" t)
+ with ls2 = (split-string f2 "/" t)
+ 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
+ (equal (file-attributes (file-truename root))
+ (file-attributes 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,6 +5040,8 @@
(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))
;; 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)
[Message part 3 (text/plain, inline)]
--
Thierry
Get my Gnupg key:
gpg --keyserver pgp.mit.edu --recv-keys 59F29997
This bug report was last modified 13 years and 58 days ago.
Previous Next
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.