From: Keith David Bershatsky <esq@lawlist.com>
To: 22322@debbugs.gnu.org
Subject: bug#22322: New Feature -- dired: Option to create a directory when copying/moving.
Date: Wed, 06 Jan 2016 12:13:38 -0800 [thread overview]
Message-ID: <m2d1te79fx.wl%esq@lawlist.com> (raw)
As a suggestion, perhaps the Emacs team would be interested in presenting the user with an option to create a new directory when copying/moving in dired-mode. This is something I use quite frequently in my own setup, because it saves me an extra step by obviating the need to create the directory beforehand.
The following is a working example of the above-mentioned concept, which is not intended to be a patch per se.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'dired-aux)
(defalias 'dired-do-create-files 'lawlist-dired-do-create-files)
(defun lawlist-dired-do-create-files (op-symbol file-creator operation arg
&optional marker-char op1 how-to)
"(1) If the path entered by the user in the mini-buffer ends in a trailing
forward slash /, then the code assumes the path is a directory -- to be
created if it does not already exist.; (2) if the trailing forward slash
is omitted, the code prompts the user to specify whether that path is a
directory."
(or op1 (setq op1 operation))
(let* (
skip-overwrite-confirmation
(fn-list (dired-get-marked-files nil arg))
(rfn-list (mapcar (function dired-make-relative) fn-list))
(dired-one-file ; fluid variable inside dired-create-files
(and (consp fn-list) (null (cdr fn-list)) (car fn-list)))
(target-dir
(if dired-one-file
(dired-get-file-for-visit) ;; filename if one file
(dired-dwim-target-directory))) ;; directory of multiple files
(default (and dired-one-file
(expand-file-name (file-name-nondirectory (car fn-list))
target-dir)) )
(defaults (dired-dwim-target-defaults fn-list target-dir))
(target (expand-file-name ; fluid variable inside dired-create-files
(minibuffer-with-setup-hook (lambda ()
(set (make-local-variable 'minibuffer-default-add-function) nil)
(setq minibuffer-default defaults))
(dired-mark-read-file-name
(concat (if dired-one-file op1 operation) " %s to: ")
target-dir op-symbol arg rfn-list default))))
(unmodified-initial-target target)
(into-dir (cond ((null how-to)
(if (and (memq system-type '(ms-dos windows-nt cygwin))
(eq op-symbol 'move)
dired-one-file
(string= (downcase
(expand-file-name (car fn-list)))
(downcase
(expand-file-name target)))
(not (string=
(file-name-nondirectory (car fn-list))
(file-name-nondirectory target))))
nil
(file-directory-p target)))
((eq how-to t) nil)
(t (funcall how-to target)))))
(if (and (consp into-dir) (functionp (car into-dir)))
(apply (car into-dir) operation rfn-list fn-list target (cdr into-dir))
(or into-dir (setq target (directory-file-name target)))
;; create new directories if they do not exist.
(when
(and
(not (file-directory-p (file-name-directory target)))
(file-exists-p (directory-file-name (file-name-directory target))))
(let ((debug-on-quit nil))
(signal 'quit `(
"A file with the same name as the proposed directory already exists."))))
(when
(and
(not (file-exists-p (directory-file-name (expand-file-name target))))
(or
(and
(null dired-one-file)
(not (string-match "\\(.*\\)\\(/$\\)" unmodified-initial-target)))
(not (file-directory-p (file-name-directory target)))
(string-match "\\(.*\\)\\(/$\\)" unmodified-initial-target)) )
(let* (
new
list-of-directories
list-of-shortened-directories
string-of-directories-a
string-of-directories-b
(max-mini-window-height 3)
(expanded (directory-file-name (expand-file-name target)))
(try expanded) )
;; Find the topmost nonexistent parent dir (variable `new')
(while (and try (not (file-exists-p try)) (not (equal new try)))
(push try list-of-directories)
(setq new try
try (directory-file-name (file-name-directory try))))
(setq list-of-shortened-directories
(mapcar
(lambda (x) (concat "..." (car (cdr (split-string x try)))))
list-of-directories))
(setq string-of-directories-a
(combine-and-quote-strings list-of-shortened-directories))
(setq string-of-directories-b (combine-and-quote-strings
(delete (car (last list-of-shortened-directories))
list-of-shortened-directories)))
(if
(and
(not (string-match "\\(.*\\)\\(/$\\)" unmodified-initial-target))
;; (cdr list-of-directories)
dired-one-file
(file-exists-p dired-one-file)
(not (file-directory-p dired-one-file)))
(if (y-or-n-p
(format "Is `%s` a directory?" (car (last list-of-directories))))
(progn
(or (y-or-n-p (format "@ `%s`, create: %s" try string-of-directories-a))
(let ((debug-on-quit nil))
(signal 'quit `("You have exited the function."))))
(make-directory expanded t)
(setq into-dir t))
(if (equal (file-name-directory target) (file-name-directory dired-one-file))
(setq new nil)
(or (y-or-n-p
(format "@ `%s`, create: %s" try string-of-directories-b))
(let ((debug-on-quit nil))
(signal 'quit `("You have exited the function."))))
(make-directory (car (split-string
(car (last list-of-directories))
(concat "/" (file-name-nondirectory target)))) t)
(setq target (file-name-directory target))
(setq into-dir t) ))
(or (y-or-n-p (format "@ `%s`, create: %s" try string-of-directories-a))
(let ((debug-on-quit nil))
(signal 'quit `("You have exited the function."))))
(make-directory expanded t)
(setq into-dir t) )
(when new
(dired-add-file new)
(dired-move-to-filename))
(setq skip-overwrite-confirmation t) ))
(lawlist-dired-create-files file-creator operation fn-list
(if into-dir ; target is a directory
(function (lambda (from)
(expand-file-name (file-name-nondirectory from) target)))
(function (lambda (_from) target)))
marker-char skip-overwrite-confirmation ))))
(defun lawlist-dired-create-files (file-creator operation fn-list name-constructor
&optional marker-char skip-overwrite-confirmation)
(let (dired-create-files-failures failures
skipped (success-count 0) (total (length fn-list)))
(let (to overwrite-query overwrite-backup-query)
(dolist (from fn-list)
(setq to (funcall name-constructor from))
(if (equal to from)
(progn
(setq to nil)
(dired-log "Cannot %s to same file: %s\n"
(downcase operation) from)))
(if (not to)
(setq skipped (cons (dired-make-relative from) skipped))
(let* ((overwrite (file-exists-p to))
(dired-overwrite-confirmed ; for dired-handle-overwrite
(and overwrite (not skip-overwrite-confirmation)
(let ((help-form '(format "\
Type SPC or `y' to overwrite file `%s',
DEL or `n' to skip to next,
ESC or `q' to not overwrite any of the remaining files,
`!' to overwrite all remaining files with no more questions." to)))
(dired-query 'overwrite-query
"Overwrite `%s'?" to))))
;; must determine if FROM is marked before file-creator
;; gets a chance to delete it (in case of a move).
(actual-marker-char
(cond ((integerp marker-char) marker-char)
(marker-char (dired-file-marker from)) ; slow
(t nil))))
(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 is a subdirectory of FROM, not a symlink,
;; and the method in use is copying, signal an error.
(and (eq t (car (file-attributes destname)))
(eq file-creator 'dired-copy-file)
(file-in-directory-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)
(if overwrite
;; If we get here, file-creator hasn't been aborted
;; and the old entry (if any) has to be deleted
;; before adding the new entry.
(dired-remove-file to))
(setq success-count (1+ success-count))
(message "%s: %d of %d" operation success-count total)
(dired-add-file to actual-marker-char))
(file-error ; FILE-CREATOR aborted
(progn
(push (dired-make-relative from)
failures)
(dired-log "%s `%s' to `%s' failed:\n%s\n"
operation from to err))))))))
(cond
(dired-create-files-failures
(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)
failures))
(failures
(dired-log-summary
(format "%s failed for %d of %d file%s"
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))
skipped))
(t
(message "%s: %s file%s"
operation success-count (dired-plural-s success-count)))))
(dired-move-to-filename))
next reply other threads:[~2016-01-06 20:13 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-01-06 20:13 Keith David Bershatsky [this message]
2016-01-06 20:15 ` bug#22322: New Feature -- dired: Option to create a directory when copying/moving John Wiegley
2021-02-07 17:06 ` Lars Ingebrigtsen
2021-02-07 17:55 ` Protesilaos Stavrou
2021-02-07 17:57 ` Lars Ingebrigtsen
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=m2d1te79fx.wl%esq@lawlist.com \
--to=esq@lawlist.com \
--cc=22322@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).