11

I'm looking for some suggestions, please, to create a custom function for dired-mode relating copying and moving files so that a directory may be created if it does not yet exist. The default behavior is to simply generate an error message if the directory does not yet exist.

STICKING POINT:  The sticking point in my mind will be dealing with an erroneous attempt to create more than one directory. For example, let's say that we want to copy files from the home directory ~/ to /tmp/test/one/ -- the directory /tmp/test/ already exists, but /tmp/test/one/ does not yet exist. Instead of typing /tmp/test/one/, I erroneously type /tmp/tesst/one -- in this circumstance, there should be an error message stating something like -- Hey, you cannot do that because /tmp/tesst/ must first exist before you can create /tmp/tesst/one. Of course, things would have gone smoothly had I correctly typed /tmp/test/one because /tmp/test/ already existed in this example.

And, lastly, I am assuming that I should just create a new function based on dired-do-create-files -- modifying the following section of code:

(if (not (or dired-one-file into-dir))
  (error "Marked %s: target must be a directory: %s" operation target))

Any guidance getting past the sticking point, or any other hazards that I haven't thought of, would be greatly appreciated.

6
  • 2
    Why should creating one new directory level be okay, but creating multiple new levels be erroneous? How about allowing any arbitrary directory, but prompting for confirmation to create it when it doesn't already exist?
    – phils
    Jul 27, 2014 at 1:26
  • @phils -- I agree that it sure would be useful to be able create multiple directories deep (in one fell swoop) if they do not yet exist, and requiring confirmation will certainly help to avoid errors. Perhaps an extra check on the first level of a new directory would be the best way to ensure I am selecting the right path -- something like -- "Hey, you are trying to create 2 new directories -- i.e., .../tesst/one -- are you sure you want to proceed?" And, if I had correctly typed /tmp/test/one the message would have said, ". . . 1 new directory -- i.e., .../one . . . ."
    – lawlist
    Jul 27, 2014 at 1:41
  • Just a comment. 1. The idea is not a bad one. 2. On the other hand, it's really not such a big deal to hit + to create the missing directory hierarchy. (And yes, when you use + you can mistype a dir name too.)
    – Drew
    Jul 27, 2014 at 1:56
  • @Drew -- thank you for looking at this thread and also for mentioning + (aka dired-create-directory). So, my revised outline now consists of modifying dired-do-create-files at the section of (if (not (or dired-one-file into-dir)) (error "Marked %s: target must be a directory: %s" operation target)) and inserting a modified version of dired-create-directory. Any ideas on how to count the number of and show the new directories to be created by dired-create-directory would be greatly appreciated -- e.g., "Shall we proceed to create 2 new directories .../tesst/one - y / n?"
    – lawlist
    Jul 27, 2014 at 2:48
  • Use code similar to that in dired-create-directory or make-directory. See the while loop in each of these fns. IOW, you want to gather the list of directories by doing something similar to such code, then prompt the user for confirmation showing that list.
    – Drew
    Jul 27, 2014 at 17:06

1 Answer 1

1

The following answer was made possible (in part) based upon the helpful comments of Drew and phils underneath the original question -- their help is greatly appreciated!

(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))

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.