[Emacs-diffs] /srv/bzr/emacs/trunk r107406: Fix bug#10489: 24.0.92 `dired-do-copy' may create infinite directory hierarchy.

[thierry volpiatto]

------------------------------------------------------------
revno: 107406
committer: thierry volpiatto <address@hidden
branch nick: trunk
timestamp: Fri 2012-02-24 19:04:03 +0100
message:
  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 dir1 is subdir of dir2.
  (copy-directory): Return error when trying to copy a directory on itself.
  Add missing copy-contents arg to tramp handler.
  
  * 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.
modified:
  lisp/ChangeLog
  lisp/dired-aux.el
  lisp/files.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2012-02-24 08:11:00 +0000
+++ b/lisp/ChangeLog    2012-02-24 18:04:03 +0000
@@ -1,3 +1,15 @@
+2012-02-24  Thierry Volpiatto  <address@hidden>
+
+       * lisp/files.el (files-equal-p): New, simple equality check between two 
filename.
+       (file-subdir-of-p): New, Check if dir1 is subdir of dir2.
+       (copy-directory): Return error when trying to copy a directory on 
itself.
+       Add missing copy-contents arg to tramp handler.
+
+       * 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.
+       (bug#10489)
+
 2012-02-24  Michael Albinus  <address@hidden>
 
        * net/ange-ftp.el (ange-ftp-parse-netrc): Suppress comment lines.

=== modified file 'lisp/dired-aux.el'
--- a/lisp/dired-aux.el 2012-01-19 07:21:25 +0000
+++ b/lisp/dired-aux.el 2012-02-24 18:04:03 +0000
@@ -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 "Cannot copy `%s' into its subdirectory `%s'" from to))
   (let ((attrs (file-attributes from)))
     (if (and recursive
             (eq t (car attrs))
@@ -1430,10 +1432,30 @@
                   (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 or one of its subdirectories.
+            ;; e.g "~/foo/" => "~/test/"
+            ;; or "~/foo/" =>"~/foo/"
+            ;; or "~/foo/ => ~/foo/bar/")
+            ;; In this case the 'name-constructor' have set the destination
+            ;; TO to "~/test/foo" because the old emacs23 behavior
+            ;; of `copy-directory' was to not create the subdirectory
+            ;; and instead copy the contents.
+            ;; With the new behavior of `copy-directory'
+            ;; (similar to the `cp' shell command) we don't
+            ;; need such a construction of the target directory,
+            ;; so modify the destination TO to "~/test/" instead of 
"~/test/foo/".
+            (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))
+              ;; If DESTNAME and FROM are the same directory or
+              ;; If DESTNAME is a subdirectory of FROM, return error.
+              (and (file-subdir-of-p destname from)
+                   (error "Cannot copy `%s' into its subdirectory `%s'"
+                          from to)))
             (condition-case err
                 (progn
                   (funcall file-creator from to dired-overwrite-confirmed)

=== modified file 'lisp/files.el'
--- a/lisp/files.el     2012-02-10 08:08:23 +0000
+++ b/lisp/files.el     2012-02-24 18:04:03 +0000
@@ -4985,6 +4985,39 @@
                 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."
+  (let ((handler (or (find-file-name-handler file1 'files-equal-p)
+                     (find-file-name-handler file2 'files-equal-p))))
+    (if handler
+        (funcall handler 'files-equal-p file1 file2)
+      (equal (file-attributes (file-truename file1))
+             (file-attributes (file-truename file2))))))
+
+(defun file-subdir-of-p (dir1 dir2)
+  "Return non-nil if DIR1 is a subdirectory of DIR2.
+Note that a directory is treated by this function as a subdirectory of itself.
+This function only works when its two arguments already exist,
+when they don't, it returns nil."
+  (let ((handler (or (find-file-name-handler dir1 'file-subdir-of-p)
+                     (find-file-name-handler dir2 'file-subdir-of-p))))
+    (if handler
+        (funcalll handler 'file-subdir-of-p dir1 dir2)
+      (when (and (file-directory-p dir1)
+                 (file-directory-p dir2))
+        (loop with f1 = (file-truename dir1)
+              with f2 = (file-truename dir2)
+              with ls1 = (or (split-string f1 "/" t) (list "/"))
+              with ls2 = (or (split-string f2 "/" t) (list "/"))
+              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
+              (files-equal-p (file-truename root) 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,12 +5044,16 @@
            (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 "Cannot copy `%s' into its subdirectory `%s'"
+           directory newname))
   ;; 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)
+       (funcall handler 'copy-directory directory
+                 newname keep-time parents copy-contents)
 
       ;; Compute target name.
       (setq directory (directory-file-name (expand-file-name directory))
@@ -5025,7 +5062,12 @@
       (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))
+            (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)))
            ;; If NEWNAME is an existing directory and COPY-CONTENTS
            ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME].
            ((not copy-contents)