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

[Thierry Volpiatto]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>> Ok, that is true for the solutions you propose below, but what's wrong
>> with the solution I have proposed:
>> Just checking if the destination directory is a subdirectory of the
>> directory we want to copy.
>
> It's not a bad plan, but it's difficult to make it catch all cases
> because it's difficult to figure out if "the destination directory is
> a subdirectory of the directory we want to copy".
> [ e.g. because of ignored cases differences, or use of different names
>   to refer to the same directory, because of MICROS~1 mangling.  ]
>
> Of course checking if two directories are one and the same isn't that
> easy to do it reliably either (e.g. for lack of inodes on Windows
> systems, and actually I'm not sure what happens if we refer to the same
> dir via two different mount points, using GNU/Linux's "bind" mounts, or
> mounting dirs multiple times).
>
> I guess the two options aren't mutually exclusive, so it's probably
> worth doing a first check before starting the whole operation (trying
> to find out if the destination is a parent of the source based on
> file-truename), and then adding another check in the recursive loop to
> try and detect inf-loops.

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?


--8<---------------cut here---------------start------------->8---
(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
the corresponding input file.

The third arg KEEP-TIME non-nil means give the output files the same
last-modified time as the old ones.  (This works on only some systems.)

A prefix arg makes KEEP-TIME non-nil.

Noninteractively, the last argument PARENTS says whether to
create parent directories if they don't exist.  Interactively,
this happens by default.

If NEWNAME names an existing directory, copy DIRECTORY as a
subdirectory there.  However, if called from Lisp with a non-nil
optional argument COPY-CONTENTS, copy the contents of DIRECTORY
directly into NEWNAME instead."
  (interactive
   (let ((dir (read-directory-name
               "Copy directory: " default-directory default-directory t nil)))
     (list dir
           (read-directory-name
            (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 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.
  (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))))
             ;(setq copy-directory-newdir-inode (file-attributes 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 "Hit inf-loop at `%s'" file)
               (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)))
--8<---------------cut here---------------end--------------->8---

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