From cb29f41624e5163a0aea4bfc98591e683807a2f8 Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Sat, 21 Oct 2017 13:05:48 +0900 Subject: [PATCH] Allow to copy/rename file into a non-existent dir * lisp/dired-aux.el (dired-create-destination-dirs): New option. (dired-maybe-create-dirs): New defun. (dired-copy-file-recursive, dired-rename-file): Use it (Bug#28834). * lisp/dired-aux-tests.el (dired-test-bug28834): Add test. * doc/emacs/dired.texi (Operating on Files): Update manual. * etc/NEWS (Changes in Specialized Modes and Packages in Emacs 27.1) Announce this change. --- doc/emacs/dired.texi | 11 +++++++ etc/NEWS | 7 +++++ lisp/dired-aux.el | 20 +++++++++++++ test/lisp/dired-aux-tests.el | 56 +++++++++++++++++++++++++++++++++++- 4 files changed, 93 insertions(+), 1 deletion(-) diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi index db5dea329b5..9348ef5042d 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -647,6 +647,14 @@ Copy the specified files (@code{dired-do-copy}). The argument @var{new} is the directory to copy into, or (if copying a single file) the new name. This is like the shell command @code{cp}. +@vindex dired-create-destination-dirs +The option @code{dired-create-destination-dirs} controls whether Dired +should create non-existent directories in the destination while +copying/renaming files. The default value @code{nil} means Dired +never creates such missing directories; the value @code{always}, +means Dired automatically creates them; the value @code{ask} +means Dired asks you for confirmation before creating them. + @vindex dired-copy-preserve-time If @code{dired-copy-preserve-time} is non-@code{nil}, then copying with this command preserves the modification time of the old file in @@ -678,6 +686,9 @@ single file, the argument @var{new} is the new name of the file. If you rename several files, the argument @var{new} is the directory into which to move the files (this is like the shell command @command{mv}). +The option @code{dired-create-destination-dirs} controls whether Dired +should create non-existent directories in @var{new}. + Dired automatically changes the visited file name of buffers associated with renamed files so that they refer to the new names. diff --git a/etc/NEWS b/etc/NEWS index d38781c9961..267d9883927 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -55,6 +55,13 @@ whether '"' is also replaced in 'electric-quote-mode'. If non-nil, * Changes in Specialized Modes and Packages in Emacs 27.1 +** Dired + ++++ +*** The new user option 'dired-create-destination-dirs' controls whether +'dired-do-copy' and 'dired-rename-file' should create non-existent +directories in the destination. + ** Ibuffer --- diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 7e2252fcf1b..7813b20b78d 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1548,6 +1548,24 @@ Special value `always' suppresses confirmation." (declare-function make-symbolic-link "fileio.c") +(defcustom dired-create-destination-dirs nil + "Whether Dired should create destination dirs when copying/removing files. +If nil, don't create them. +If `always', create them without ask. +If `ask', ask for user confirmation." + :type '(choice (const :tag "Never create non-existent dirs" nil) + (const :tag "Always create non-existent dirs" always) + (const :tag "Ask for user confirmation" ask)) + :group 'dired + :version "27.1") + +(defun dired-maybe-create-dirs (dir) + "Create DIR if doesn't exist according to `dired-create-destination-dirs'." + (when (and dired-create-destination-dirs (not (file-exists-p dir))) + (if (or (eq dired-create-destination-dirs 'always) + (yes-or-no-p (format "Create destination dir `%s'? " dir))) + (dired-create-directory dir)))) + (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) (when (and (eq t (car (file-attributes from))) @@ -1564,6 +1582,7 @@ Special value `always' suppresses confirmation." (if (stringp (car attrs)) ;; It is a symlink (make-symbolic-link (car attrs) to ok-flag) + (dired-maybe-create-dirs (file-name-directory to)) (copy-file from to ok-flag preserve-time)) (file-date-error (push (dired-make-relative from) @@ -1573,6 +1592,7 @@ Special value `always' suppresses confirmation." ;;;###autoload (defun dired-rename-file (file newname ok-if-already-exists) (dired-handle-overwrite newname) + (dired-maybe-create-dirs (file-name-directory newname)) (rename-file file newname ok-if-already-exists) ; error is caught in -create-files ;; Silently rename the visited file of any buffer visiting this file. (and (get-file-buffer file) diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index d41feb1592f..9316217dd2a 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -20,7 +20,7 @@ ;;; Code: (require 'ert) (require 'dired-aux) - +(eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." @@ -40,5 +40,59 @@ (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) (delete-file foo)))) +;; Auxiliar macro for `dired-test-bug28834': it binds +;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. +;; If YES-OR-NO is non-nil, it binds `yes-or-no-p' to +;; to avoid the prompt. +(defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body) + (declare ((debug form symbolp body))) + (let ((foo (make-symbol "foo"))) + `(let* ((,foo (make-temp-file "foo" 'dir)) + (dired-create-destination-dirs ,create-dirs)) + (setq from (make-temp-file "from")) + (setq to-cp + (expand-file-name + "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) + (setq to-mv + (expand-file-name + "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) + (unwind-protect + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body) + ;; clean up + (delete-directory ,foo 'recursive) + (delete-file from))))) + +(ert-deftest dired-test-bug28834 () + "test for https://debbugs.gnu.org/28834 ." + (let (from to-cp to-mv) + ;; `dired-create-destination-dirs' set to 'always. + (with-dired-bug28834-test + 'always nil + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + ;; `dired-create-destination-dirs' set to nil. + (with-dired-bug28834-test + nil nil + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))) + ;; `dired-create-destination-dirs' set to 'ask. + (with-dired-bug28834-test + 'ask 'yes ; Answer `yes' + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + (with-dired-bug28834-test + 'ask 'no ; Answer `no' + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))))) + + (provide 'dired-aux-tests) ;; dired-aux-tests.el ends here -- 2.39.2