bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy

[Thierry Volpiatto]

Andreas Schwab <schwab@linux-m68k.org> writes:

>> So, any objections to apply my patch to trunk with these changes?
>
> You also need to check whether the target is a subdirectory of the
> source.

To clarify:

--8<---------------cut here---------------start------------->8---
thierry@thierry-MM061:~$ cd ~/tmp/Test/
thierry@thierry-MM061:~/tmp/Test$ ls -R
.:
Test1

./Test1:
Test2

./Test1/Test2:
Test3

./Test1/Test2/Test3:
thierry@thierry-MM061:~/tmp/Test$ LC_ALL=C cp -r ~/tmp/Test/ 
~/tmp/Test/Test1/Test2/Test3/
cp: cannot copy a directory, `/home/thierry/tmp/Test/', into itself, 
`/home/thierry/tmp/Test/Test1/Test2/Test3/Test'
--8<---------------cut here---------------end--------------->8---

So we need to check this. (See `file-subdir-of-p' in this patch)

##Merge of all patches applied from revision 118409
## patch-r118414: Bugfix bug#10489, dired-do-copy may create infinite directory 
hierarchy.
## patch-r118411: * lisp/dired-aux.el (dired-copy-file-recursive): Use 
file-equal-p.
## patch-r118412: * lisp/files.el (file-subdir-of-p): Check if file1 is subdir 
of file2.
## 
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1264,24 +1264,27 @@
 
 (defun dired-copy-file-recursive (from to ok-flag &optional
                                       preserve-time top recursive)
+  (when (or (files-equal-p from to)
+            (file-subdir-of-p from to))
+    (error "Can't copy directory `%s' on itself" from))
   (let ((attrs (file-attributes from)))
     (if (and recursive
-            (eq t (car attrs))
-            (or (eq recursive 'always)
-                (yes-or-no-p (format "Recursive copies of %s? " from))))
-       ;; This is a directory.
-       (copy-directory from to preserve-time)
+             (eq t (car attrs))
+             (or (eq recursive 'always)
+                 (yes-or-no-p (format "Recursive copies of %s? " from))))
+        ;; This is a directory.
+        (copy-directory from to preserve-time)
       ;; Not a directory.
       (or top (dired-handle-overwrite to))
       (condition-case err
-         (if (stringp (car attrs))
-             ;; It is a symlink
-             (make-symbolic-link (car attrs) to ok-flag)
-           (copy-file from to ok-flag preserve-time))
-       (file-date-error
-        (push (dired-make-relative from)
-              dired-create-files-failures)
-        (dired-log "Can't set date on %s:\n%s\n" from err))))))
+          (if (stringp (car attrs))
+              ;; It is a symlink
+              (make-symbolic-link (car attrs) to ok-flag)
+            (copy-file from to ok-flag preserve-time))
+        (file-date-error
+         (push (dired-make-relative from)
+               dired-create-files-failures)
+         (dired-log "Can't set date on %s:\n%s\n" from err))))))
 
 ;;;###autoload
 (defun dired-rename-file (file newname ok-if-already-exists)
@@ -1378,7 +1381,7 @@
 
 ;; The basic function for half a dozen variations on cp/mv/ln/ln -s.
 (defun dired-create-files (file-creator operation fn-list name-constructor
-                                       &optional marker-char)
+                                        &optional marker-char)
   "Create one or more new files from a list of existing files FN-LIST.
 This function also handles querying the user, updating Dired
 buffers, and displaying a success or failure message.
@@ -1401,10 +1404,14 @@
 Optional MARKER-CHAR is a character with which to mark every
 newfile's entry, or t to use the current marker character if the
 old file was marked."
-  (let (dired-create-files-failures failures
-       skipped (success-count 0) (total (length fn-list)))
-    (let (to overwrite-query
-            overwrite-backup-query)    ; for dired-handle-overwrite
+  (let (dired-create-files-failures
+        failures
+        skipped
+        (success-count 0)
+        (total (length fn-list)))
+    (let (to
+          overwrite-query
+          overwrite-backup-query)      ; for dired-handle-overwrite
       (dolist (from fn-list)
         (setq to (funcall name-constructor from))
         (if (equal to from)
@@ -1430,10 +1437,25 @@
                   (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)
+                         (or (files-equal-p from destname)
+                             (file-directory-p to))
+                         (eq file-creator 'dired-copy-file))
+                (setq to destname)))
             (condition-case err
                 (progn
                   (funcall file-creator from to dired-overwrite-confirmed)
@@ -1456,25 +1478,25 @@
       (setq failures (nconc failures dired-create-files-failures))
       (dired-log-summary
        (format "%s failed for %d file%s in %d requests"
-               operation (length failures)
-               (dired-plural-s (length failures))
-               total)
+               operation (length failures)
+               (dired-plural-s (length failures))
+               total)
        failures))
      (failures
       (dired-log-summary
        (format "%s failed for %d of %d file%s"
-               operation (length failures)
-               total (dired-plural-s total))
+               operation (length failures)
+               total (dired-plural-s total))
        failures))
      (skipped
       (dired-log-summary
        (format "%s: %d of %d file%s skipped"
-               operation (length skipped) total
-               (dired-plural-s total))
+               operation (length skipped) total
+               (dired-plural-s total))
        skipped))
      (t
       (message "%s: %s file%s"
-              operation success-count (dired-plural-s success-count)))))
+               operation success-count (dired-plural-s success-count)))))
   (dired-move-to-filename))
 
 (defun dired-do-create-files (op-symbol file-creator operation arg
diff --git a/lisp/files.el b/lisp/files.el
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4902,6 +4902,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 file1)
+              with f2 = (expand-file-name 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
+              (string= (file-truename (directory-file-name root))
+                       (file-truename (directory-file-name 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
@@ -4928,10 +4957,13 @@
            (format "Copy directory %s to: " dir)
            default-directory default-directory nil nil)
           current-prefix-arg t nil)))
+  (when (or (files-equal-p directory newname)
+            (file-subdir-of-p directory newname))
+    (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))))
+                     (find-file-name-handler newname 'copy-directory))))
     (if handler
        (funcall handler 'copy-directory directory newname keep-time parents)
 

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