Emacs——复制/移动文件——必要时创建目录

Question

请给我一些建议，帮忙创建一个自定义函数用于 dired-mode 中的文件复制和移动，使得如果目录不存在就可以创建。默认行为是如果目录不存在则生成错误信息。

难点: 我认为最大的难点是如何处理错误地尝试创建多个目录的情况。例如，假设我们想将文件从主目录~/复制到/tmp/test/one/ -- 目录/tmp/test/已经存在，但/tmp/test/one/还不存在。在这种情况下，如果我错误地输入了/tmp/tesst/one而不是/tmp/test/one/，应该会出现错误提示，类似于嘿，你不能这样做，因为在创建/tmp/tesst/one之前必须先存在/tmp/tesst/。 当然，如果我在这个例子中正确地输入了/tmp/test/one，事情就会顺利进行，因为在这个例子中/tmp/test/已经存在。

最后，我假设我应该基于dired-do-create-files创建一个新函数-- 修改以下代码段：

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

如果能够提供克服难关或其他可能存在的危险的任何指导，将不胜感激。

- lawlist

---

为什么创建一个新目录级别是可以的，但创建多个新级别就会出错？如果允许任意目录，但在它不存在时提示确认来创建它呢？ - phils

@phils -- 我同意，如果能够一次性创建多个目录（如果它们尚不存在），那肯定会非常有用，并且需要确认肯定有助于避免错误。也许在新目录的第一级上进行额外的检查是确保我选择正确路径的最佳方法--例如--“嘿，您正在尝试创建2个新目录--即，.../tesst/one--您确定要继续吗？” 如果我已经正确输入了 /tmp/test/one，那么消息将会说：“……1个新目录--即，.../one……” - lawlist

只是一条注释。1. 这个想法并不差。2. 另一方面，按下“+”键创建缺失的目录层次结构并不是什么大不了的事情。（当然，使用“+”时也可能会误输入目录名称。） - Drew

@Drew -- 感谢您查看此线程并提到 +（又名 dired-create-directory）。因此，我修改后的大纲现在包括在 (if (not (or dired-one-file into-dir)) (error "Marked %s: target must be a directory: %s" operation target)) 部分修改 dired-do-create-files 并插入修改后的 dired-create-directory 版本。任何有关如何计算 和 显示 dired-create-directory 将要创建的新目录数量的想法都将不胜感激 - 例如，“我们是否继续创建2个新目录 .../tesst/one - y / n？” - lawlist

使用类似于dired-create-directory或make-directory中的代码。请参见这些函数中的while循环。换句话说，您希望通过执行类似于此类代码来收集目录列表，然后提示用户确认并显示该列表。 - Drew

@Drew -- 非常感谢你 -- 是的，那样就可以了。我现在有一个可用的草稿，只需要解决一些小问题... - lawlist

Answer 1

以下答案部分地得益于原问题下Drew和phils的有益评论 - 非常感谢他们的帮助！

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

- lawlist