##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. ## 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,26 @@ (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) + (when (file-equal-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 +1380,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. @@ -1402,9 +1404,9 @@ 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))) + skipped (success-count 0) (total (length fn-list))) (let (to overwrite-query - overwrite-backup-query) ; for dired-handle-overwrite + overwrite-backup-query) ; for dired-handle-overwrite (dolist (from fn-list) (setq to (funcall name-constructor from)) (if (equal to from) @@ -1430,10 +1432,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 (file-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 +1473,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,12 @@ directory 'full directory-files-no-dot-files-regexp))) (delete-directory-internal directory))))) +(defun file-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)) + (string= (file-truename (expand-file-name file1)) + (file-truename (expand-file-name file2))))) + (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 +4934,12 @@ (format "Copy directory %s to: " dir) default-directory default-directory nil nil) current-prefix-arg t nil))) + (when (file-equal-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)