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

Previous Next

Full log

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

From: Thierry Volpiatto <thierry.volpiatto <at> gmail.com>
To: Michael Albinus <michael.albinus <at> gmx.de>
Cc: 10489 <at> debbugs.gnu.org
Subject: Re: bug#10489: 24.0.92;
	dired-do-copy may create infinite directory hierarchy
Date: Tue, 28 Feb 2012 09:15:25 +0100

Hi Michael,

Michael Albinus <michael.albinus <at> gmx.de> writes:

> Thierry Volpiatto <thierry.volpiatto <at> gmail.com> writes:
>
>> Here the patch:
>
> `files-equal-p' still returns t for two non-existing files. Shall be
> fixed too.
Fixed.

> Btw, this is the only primitive function which has the prefix "files-",
> all other start with prefix "file-". Is this necessary?
I wrote files because comparing two files, but I don't care of this,
just rename it to file-
> (No it is not important, but if we want change it, we must do it before
> the 24.1 release).

--8<---------------cut here---------------start------------->8---
diff --git a/lisp/files.el b/lisp/files.el
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4985,27 +4985,27 @@
 		 directory 'full directory-files-no-dot-files-regexp)))
       (delete-directory-internal directory)))))
 
-(defun files-equal-p (file1 file2)
+(defun file-equal-p (file1 file2)
   "Return non-nil if FILE1 and FILE2 name the same file.
 Ordinary files are considered to be the same if `file-attributes'
 returns `equal' values for them."
-  (let ((handler (or (find-file-name-handler file1 'files-equal-p)
-                     (find-file-name-handler file2 'files-equal-p))))
+  (let ((handler (or (find-file-name-handler file1 'file-equal-p)
+                     (find-file-name-handler file2 'file-equal-p))))
     (if handler
-        (funcall handler 'files-equal-p file1 file2)
-      (equal (file-attributes (file-truename file1))
-             (file-attributes (file-truename file2))))))
+        (funcall handler 'file-equal-p file1 file2)
+      (let ((f1-attr (file-attributes (file-truename file1)))
+            (f2-attr (file-attributes (file-truename file2))))
+        (and f1-attr f2-attr (equal f1-attr f2-attr))))))
 
 (defun file-subdir-of-p (dir1 dir2)
   "Return non-nil if DIR1 is a subdirectory of DIR2.
 A directory is considered to be a subdirectory of itself.
-Return nil if DIR1 or DIR2 are not existing directories."
+Return nil if top directory DIR2 is not an existing directory."
   (let ((handler (or (find-file-name-handler dir1 'file-subdir-of-p)
                      (find-file-name-handler dir2 'file-subdir-of-p))))
     (if handler
         (funcall handler 'file-subdir-of-p dir1 dir2)
-      (when (and (file-directory-p dir1)
-                 (file-directory-p dir2))
+      (when (file-directory-p dir2) ; Top dir must exist.
 	(setq dir1 (file-truename dir1)
 	      dir2 (file-truename dir2))
 	(let ((ls1  (or (split-string dir1 "/" t) '("/")))
@@ -5019,7 +5019,7 @@
 	    (setq ls1 (cdr ls1)
 		  ls2 (cdr ls2)))
 	  (unless mismatch
-	    (files-equal-p (file-truename root) dir2)))))))
+	    (file-equal-p root dir2)))))))
 
 (defun copy-directory (directory newname &optional keep-time parents copy-contents)
   "Copy DIRECTORY to NEWNAME.  Both args must be strings.
@@ -5065,12 +5065,7 @@
       (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)
-             ;; `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)))
+	     (make-directory newname parents))
 	    ;; If NEWNAME is an existing directory and COPY-CONTENTS
 	    ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME].
 	    ((not copy-contents)
--8<---------------cut here---------------end--------------->8---

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