-;;; dired-async.el --- Copy/move/delete asynchronously in dired.
+;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
-;; Copyright (C) 2012~2013 John Wiegley
-;; Copyright (C) 2012~2013 Thierry Volpiatto
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
;; Authors: John Wiegley <jwiegley@gmail.com>
;; Thierry Volpiatto <thierry.volpiatto@gmail.com>
-;; Version: 1.0
;; Keywords: dired async network
;; X-URL: https://github.com/jwiegley/dired-async
;;; Commentary:
;; This file provide a redefinition of `dired-create-file' function,
-;; which must be loaded *after* dired-aux.el, performs copies,
-;; moves and all what is handled by `dired-create-file' in the background
-;; using a slave Emacs process, by means of the async.el module.
+;; performs copies, moves and all what is handled by `dired-create-file'
+;; in the background using a slave Emacs process,
+;; by means of the async.el module.
;; To use it, put this in your .emacs:
-;;
-;; (eval-after-load "dired-aux"
-;; '(require 'dired-async))
-;;
-;;
+
+;; (dired-async-mode 1)
+
+;; This will enable async copy/rename etc...
+;; in dired and helm.
;;; Code:
\f
(eval-when-compile
(defvar async-callback))
-(defvar dired-async-operation nil)
(defgroup dired-async nil
"Copy rename files asynchronously from dired."
:group 'dired-async
:type 'string)
-(defcustom dired-async-be-async t
- "When non--nil make `dired-create-file' async.
-This allow to turn off async features provided to this package."
- :group 'dired-async
- :type 'boolean)
-
-(defvaralias 'helm-async-be-async 'dired-async-be-async)
-
(defface dired-async-message
'((t (:foreground "yellow")))
"Face used for mode-line message."
:group 'dired-async)
+(defface dired-async-failures
+ '((t (:foreground "red")))
+ "Face used for mode-line message."
+ :group 'dired-async)
+
(defface dired-async-mode-message
- '((t (:background "Firebrick1")))
- "Face used for `dired-async-mode' lighter."
+ '((t (:foreground "Gold")))
+ "Face used for `dired-async--modeline-mode' lighter."
:group 'dired-async)
-(define-minor-mode dired-async-mode
+(define-minor-mode dired-async--modeline-mode
"Notify mode-line that an async process run."
:group 'dired-async
:global t
:lighter (:eval (propertize (format " [%s Async job(s) running]"
(length (dired-async-processes)))
'face 'dired-async-mode-message))
- (unless dired-async-mode
+ (unless dired-async--modeline-mode
(let ((visible-bell t)) (ding))))
-(defun dired-async-mode-line-message (text &rest args)
+(defun dired-async-mode-line-message (text face &rest args)
"Notify end of operation in `mode-line'."
(message nil)
(let ((mode-line-format (concat
(if args
(apply #'format text args)
text)
- 'face 'dired-async-message))))
+ 'face face))))
(force-mode-line-update)
(sit-for 3)
(force-mode-line-update)))
(interactive)
(let* ((processes (dired-async-processes))
(proc (car (last processes))))
- (delete-process proc)
+ (and proc (delete-process proc))
(unless (> (length processes) 1)
- (dired-async-mode -1))))
+ (dired-async--modeline-mode -1))))
-(defun dired-async-after-file-create (len-flist)
+(defun dired-async-after-file-create (total operation failures skipped)
"Callback function used for operation handled by `dired-create-file'."
(unless (dired-async-processes)
;; Turn off mode-line notification
;; only when last process end.
- (dired-async-mode -1))
- (when dired-async-operation
+ (dired-async--modeline-mode -1))
+ (when operation
(if (file-exists-p dired-async-log-file)
(progn
(pop-to-buffer (get-buffer-create "*dired async*"))
(delete-file dired-async-log-file))
(run-with-timer
0.1 nil
- dired-async-message-function "Asynchronous %s of %s file(s) on %s file(s) done"
- (car dired-async-operation) (cadr dired-async-operation) len-flist))))
+ (lambda ()
+ ;; First send error messages.
+ (cond (failures
+ (funcall dired-async-message-function
+ "%s failed for %d of %d file%s"
+ 'dired-async-failures
+ (car operation) (length failures)
+ total (dired-plural-s total)))
+ (skipped
+ (funcall dired-async-message-function
+ "%s: %d of %d file%s skipped"
+ 'dired-async-failures
+ (car operation) (length skipped) total
+ (dired-plural-s total))))
+ ;; Finally send the success message.
+ (funcall dired-async-message-function
+ "Asynchronous %s of %s file(s) on %s file(s) done"
+ 'dired-async-message
+ (car operation) (cadr operation) total))))))
(defun dired-async-maybe-kill-ftp ()
"Return a form to kill ftp process in child emacs."
(buffer-name b)) b))))
(when buf (kill-buffer buf))))))
-(defun dired-create-files (file-creator operation fn-list name-constructor
- &optional marker-char)
- "Create one or more new files from a list of existing files FN-LIST.
-This function also handles querying the user, updating Dired
-buffers, and displaying a success or failure message.
+(defvar overwrite-query)
+(defun dired-async-create-files (file-creator operation fn-list name-constructor
+ &optional _marker-char)
+ "Same as `dired-create-files' but asynchronous.
-FILE-CREATOR should be a function. It is called once for each
-file in FN-LIST, and must create a new file, querying the user
-and updating Dired buffers as necessary. It should accept three
-arguments: the old file name, the new name, and an argument
-OK-IF-ALREADY-EXISTS with the same meaning as in `copy-file'.
-
-OPERATION should be a capitalized string describing the operation
-performed (e.g. `Copy'). It is used for error logging.
-
-FN-LIST is the list of files to copy (full absolute file names).
-
-NAME-CONSTRUCTOR should be a function accepting a single
-argument, the name of an old file, and returning either the
-corresponding new file name or nil to skip.
-
-Optional MARKER-CHAR is a character with which to mark every
-newfile's entry, or t to use the current marker character if the
-old file was marked."
- (setq dired-async-operation nil)
- (let (dired-create-files-failures failures async-fn-list
- skipped (success-count 0) (total (length fn-list))
- (callback `(lambda (&optional ignore)
- (dired-async-after-file-create ,(length fn-list)))))
- (let (to overwrite-query
- overwrite-backup-query) ; for dired-handle-overwrite
+See `dired-create-files' for the behavior of arguments."
+ (setq overwrite-query nil)
+ (let ((total (length fn-list))
+ failures async-fn-list skipped callback)
+ (let (to)
(dolist (from fn-list)
(setq to (funcall name-constructor from))
(if (equal to from)
(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
- (let ((help-form '(format "\
+ (let* ((overwrite (and (null (eq file-creator 'backup-file))
+ (file-exists-p to)))
+ (dired-overwrite-confirmed ; for dired-handle-overwrite
+ (and overwrite
+ (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))))
- ;; Handle the `dired-copy-file' file-creator specially
- ;; When copying a directory to another directory or
- ;; possibly to itself or one of its subdirectories.
- ;; e.g "~/foo/" => "~/test/"
- ;; or "~/foo/" =>"~/foo/"
- ;; or "~/foo/ => ~/foo/bar/")
- ;; In this case the 'name-constructor' have set the destination
- ;; TO to "~/test/foo" because the old emacs23 behavior
- ;; of `copy-directory' was to not create the subdirectory
- ;; and instead copy the contents.
- ;; With the new behavior of `copy-directory'
- ;; (similar to the `cp' shell command) we don't
- ;; need such a construction of the target directory,
- ;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
- (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)))
- (if dired-async-be-async
- (if overwrite
- (or (and dired-overwrite-confirmed
- (push (cons from to) async-fn-list))
- (progn
- (push (dired-make-relative from) failures)
- (dired-log "%s `%s' to `%s' failed"
- operation from to)))
- (push (cons from to) async-fn-list))
- (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)))))))))
- ;; Handle error happening in host emacs.
- (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))))
+`!' to overwrite all remaining files with no more questions." ,to)))
+ (dired-query 'overwrite-query "Overwrite `%s'?" to)))))
+ ;; Handle the `dired-copy-file' file-creator specially
+ ;; When copying a directory to another directory or
+ ;; possibly to itself or one of its subdirectories.
+ ;; e.g "~/foo/" => "~/test/"
+ ;; or "~/foo/" =>"~/foo/"
+ ;; or "~/foo/ => ~/foo/bar/")
+ ;; In this case the 'name-constructor' have set the destination
+ ;; TO to "~/test/foo" because the old emacs23 behavior
+ ;; of `copy-directory' was to not create the subdirectory
+ ;; and instead copy the contents.
+ ;; With the new behavior of `copy-directory'
+ ;; (similar to the `cp' shell command) we don't
+ ;; need such a construction of the target directory,
+ ;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
+ (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)))
+ (if overwrite
+ (or (and dired-overwrite-confirmed
+ (push (cons from to) async-fn-list))
+ (progn
+ (push (dired-make-relative from) failures)
+ (dired-log "%s `%s' to `%s' failed\n"
+ operation from to)))
+ (push (cons from to) async-fn-list)))))
+ ;; When async-fn-list is empty that's mean only one file
+ ;; had to be copied and user finally answer NO.
+ ;; In this case async process will never start and callback
+ ;; will have no chance to run, so notify failures here.
+ (unless async-fn-list
+ (cond (failures
+ (funcall dired-async-message-function
+ "%s failed for %d of %d file%s"
+ 'dired-async-failures
+ operation (length failures)
+ total (dired-plural-s total)))
+ (skipped
+ (funcall dired-async-message-function
+ "%s: %d of %d file%s skipped"
+ 'dired-async-failures
+ operation (length skipped) total
+ (dired-plural-s total)))))
+ ;; Setup callback.
+ (setq callback
+ (lambda (&optional _ignore)
+ (dired-async-after-file-create
+ total (list operation (length async-fn-list)) failures skipped)
+ (when (string= (downcase operation) "rename")
+ (cl-loop for (file . to) in async-fn-list
+ for bf = (get-file-buffer file)
+ do (and bf (with-current-buffer bf
+ (set-visited-file-name to nil t))))))))
;; Start async process.
- (when (and async-fn-list dired-async-be-async)
+ (when async-fn-list
(async-start `(lambda ()
- (require 'cl-lib) (require 'dired-aux)
+ (require 'cl-lib) (require 'dired-aux) (require 'dired-x)
,(async-inject-variables dired-async-env-variables-regexp)
(condition-case err
- (let ((dired-recursive-copies (quote always)))
- (cl-loop for (f . d) in (quote ,async-fn-list)
- do (funcall (quote ,file-creator) f d t)))
+ (let ((dired-recursive-copies (quote always))
+ (dired-copy-preserve-time
+ ,dired-copy-preserve-time))
+ (setq overwrite-backup-query nil)
+ ;; Inline `backup-file' as long as it is not
+ ;; available in emacs.
+ (defalias 'backup-file
+ ;; Same feature as "cp --backup=numbered from to"
+ ;; Symlinks are copied as file from source unlike
+ ;; `dired-copy-file' which is same as cp -d.
+ ;; Directories are omitted.
+ (lambda (from to ok)
+ (cond ((file-directory-p from) (ignore))
+ (t (let ((count 0))
+ (while (let ((attrs (file-attributes to)))
+ (and attrs (null (nth 0 attrs))))
+ (cl-incf count)
+ (setq to (concat (file-name-sans-versions to)
+ (format ".~%s~" count)))))
+ (condition-case err
+ (copy-file from to ok dired-copy-preserve-time)
+ (file-date-error
+ (push (dired-make-relative from)
+ dired-create-files-failures)
+ (dired-log "Can't set date on %s:\n%s\n" from err)))))))
+ ;; Now run the FILE-CREATOR function on files.
+ (cl-loop with fn = (quote ,file-creator)
+ for (from . dest) in (quote ,async-fn-list)
+ do (funcall fn from dest t)))
(file-error
(with-temp-file ,dired-async-log-file
(insert (format "%S" err)))))
,(dired-async-maybe-kill-ftp))
callback)
;; Run mode-line notifications while process running.
- (dired-async-mode 1)
- (setq dired-async-operation (list operation (length async-fn-list)))
- (message "%s proceeding asynchronously..." operation)))
- (unless dired-async-be-async
- (dired-move-to-filename)))
+ (dired-async--modeline-mode 1)
+ (message "%s proceeding asynchronously..." operation))))
+
+(defadvice dired-create-files (around dired-async)
+ (dired-async-create-files file-creator operation fn-list
+ name-constructor marker-char))
+
+;;;###autoload
+(define-minor-mode dired-async-mode
+ "Do dired actions asynchronously."
+ :group 'dired-async
+ :global t
+ (if dired-async-mode
+ (if (fboundp 'advice-add)
+ (advice-add 'dired-create-files :override #'dired-async-create-files)
+ (ad-activate 'dired-create-files))
+ (if (fboundp 'advice-remove)
+ (advice-remove 'dired-create-files #'dired-async-create-files)
+ (ad-deactivate 'dired-create-files))))
(provide 'dired-async)