GNU bug report logs - #10489
24.0.92; dired-do-copy may create infinite directory hierarchy

Previous Next

Full log

Message #258 received at 10489 <at> debbugs.gnu.org (full text, mbox):

From: Thierry Volpiatto <thierry.volpiatto <at> gmail.com>
To: Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: 10489 <at> debbugs.gnu.org, Michael Albinus <michael.albinus <at> gmx.de>
Subject: Re: bug#10489: 24.0.92;
	dired-do-copy may create infinite directory hierarchy
Date: Thu, 23 Feb 2012 23:10:18 +0100

[Message part 1 (text/plain, inline)]

Stefan Monnier <monnier <at> 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.

[Singlepatch-r118952ToTip.patch (text/x-diff, inline)]

##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

[Message part 3 (text/plain, inline)]

-- 
  Thierry
Get my Gnupg key:
gpg --keyserver pgp.mit.edu --recv-keys 59F29997 

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.