[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarch
From: |
Thierry Volpiatto |
Subject: |
bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy |
Date: |
Fri, 24 Feb 2012 08:16:08 +0100 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.0.93 (gnu/linux) |
Thierry Volpiatto <thierry.volpiatto@gmail.com> writes:
> Stefan Monnier <monnier@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.
# HG changeset patch
# User Thierry Volpiatto <thierry.volpiatto@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)
--
Thierry
Get my Gnupg key:
gpg --keyserver pgp.mit.edu --recv-keys 59F29997
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, (continued)
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Michael Albinus, 2012/02/21
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/21
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Stefan Monnier, 2012/02/21
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/22
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Stefan Monnier, 2012/02/22
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/23
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/23
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Stefan Monnier, 2012/02/23
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/23
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy,
Thierry Volpiatto <=
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Eli Zaretskii, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Michael Albinus, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Michael Albinus, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Thierry Volpiatto, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Michael Albinus, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Eli Zaretskii, 2012/02/24
- bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy, Michael Albinus, 2012/02/24