From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Keith David Bershatsky Newsgroups: gmane.emacs.bugs Subject: bug#22322: New Feature -- dired: Option to create a directory when copying/moving. Date: Wed, 06 Jan 2016 12:13:38 -0800 Message-ID: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 (generated by - "") Content-Type: text/plain; charset=US-ASCII X-Trace: ger.gmane.org 1452111267 21498 80.91.229.3 (6 Jan 2016 20:14:27 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Wed, 6 Jan 2016 20:14:27 +0000 (UTC) To: 22322@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Wed Jan 06 21:14:14 2016 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1aGuTD-0004d9-8J for geb-bug-gnu-emacs@m.gmane.org; Wed, 06 Jan 2016 21:14:11 +0100 Original-Received: from localhost ([::1]:55962 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGuTC-0003gN-Hg for geb-bug-gnu-emacs@m.gmane.org; Wed, 06 Jan 2016 15:14:10 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:52671) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGuT8-0003g9-9U for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:14:08 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aGuT4-0000Bn-6f for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:14:06 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:52411) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGuT4-0000Bj-2w for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:14:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84) (envelope-from ) id 1aGuT3-0000lE-Rw for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:14:01 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Keith David Bershatsky Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 06 Jan 2016 20:14:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 22322 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: X-Debbugs-Original-To: bug-gnu-emacs@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.14521112362904 (code B ref -1); Wed, 06 Jan 2016 20:14:01 +0000 Original-Received: (at submit) by debbugs.gnu.org; 6 Jan 2016 20:13:56 +0000 Original-Received: from localhost ([127.0.0.1]:40631 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aGuSx-0000kk-Qm for submit@debbugs.gnu.org; Wed, 06 Jan 2016 15:13:56 -0500 Original-Received: from eggs.gnu.org ([208.118.235.92]:33332) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aGuSw-0000kU-8E for submit@debbugs.gnu.org; Wed, 06 Jan 2016 15:13:54 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aGuSp-00007p-D1 for submit@debbugs.gnu.org; Wed, 06 Jan 2016 15:13:48 -0500 Original-Received: from lists.gnu.org ([2001:4830:134:3::11]:55339) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGuSp-00007h-2F for submit@debbugs.gnu.org; Wed, 06 Jan 2016 15:13:47 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:52490) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGuSn-0003e0-AN for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:13:46 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aGuSj-00005k-7E for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:13:45 -0500 Original-Received: from cobb.liquidweb.com ([50.28.13.150]:56671) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGuSi-00005b-U7 for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:13:41 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=lawlist.com; s=default; h=Content-Type:MIME-Version:Subject:To:From:Message-ID:Date; bh=nEPvSa1Iq7skMwtS2kwdHesZix3MafyjAmcr9O6g1yw=; b=9R6uRklKOHz7wg5H6RDVIsrXjBT1Ma3p8zMVmhucDQ3LaKPbtfrpTljdZFkOkqP+pVGeGbra8x2L5h7mSFK/X7OQ0qlmp5cETMp60HTDou35N2+GtqYwzBxOy8qu2FSd; Original-Received: from cpe-45-48-239-195.socal.res.rr.com ([45.48.239.195]:51550 helo=server.local.localhost) by cobb.liquidweb.com with esmtp (Exim 4.82) (envelope-from ) id 1aGuSe-0003sX-KH for bug-gnu-emacs@gnu.org; Wed, 06 Jan 2016 15:13:36 -0500 X-AntiAbuse: This header was added to track abuse, please include it with any abuse report X-AntiAbuse: Primary Hostname - cobb.liquidweb.com X-AntiAbuse: Original Domain - gnu.org X-AntiAbuse: Originator/Caller UID/GID - [47 12] / [47 12] X-AntiAbuse: Sender Address Domain - lawlist.com X-Get-Message-Sender-Via: cobb.liquidweb.com: acl_c_relayhosts_text_entry: lawlist|lawlist.com X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.bugs:111306 Archived-At: 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))