[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: |
Thu, 23 Feb 2012 23:10:18 +0100 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.0.93 (gnu/linux) |
Stefan Monnier <monnier@iro.umontreal.ca> 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 "⊆" rather than "⊂".
Done, you should have received the patch.
>
> 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.
##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
--
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, 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, 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 <=
- 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, 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