-;;; dired-async --- Copy/move/delete asynchronously in dired
+;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
-;; Copyright (C) 2012 John Wiegley
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Authors: John Wiegley <jwiegley@gmail.com>
+;; Thierry Volpiatto <thierry.volpiatto@gmail.com>
-;; Author: John Wiegley <jwiegley@gmail.com>
-;; Created: 14 Jun 2012
-;; Version: 1.0
;; Keywords: dired async network
;; X-URL: https://github.com/jwiegley/dired-async
\f
;;; Commentary:
-;; The function, which must be loaded *after* dired-aux.el, performs copies,
-;; moves and deletes 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))
-;;
-;; NOTE: If you have `delete-by-moving-to-trash' set to t, and you enable
-;; `dired-async-use-native-commands', you will need to install the following
-;; bash script on your system's PATH as "rmtrash". Please edit to suit your
-;; system. It depends on the GNU realpath
-;;
-;; #!/bin/bash
-;;
-;; function mv_to_trash {
-;; path="$1"
-;; trash="$2"
-;;
-;; if test -L "$path"; then
-;; rm -f "$path" # don't trash symlinks, just remove them
-;; else
-;; target="$trash"/$(basename "$path")
-;; if test -e "$target"; then
-;; for (( index=$$ ; 1; index=index+1 )); do
-;; target="$target"-"$index"
-;; if ! test -e "$target"; then
-;; break
-;; fi
-;; done
-;; fi
-;; mv -f "$path" "$target" # don't worry about race-condition overwrites
-;; fi
-;; }
-;;
-;; for item in "$@"; do
-;; if [[ -n "$item" && ${item:0:1} == '-' ]]; then
-;; continue
-;; elif ! test -e "$item"; then
-;; continue
-;; else
-;; target=$(realpath "$item")
-;; if [[ "$target" =~ ^/Volumes/([^/]+)/ ]]; then
-;; mv_to_trash "$item" "/Volumes/${BASH_REMATCH[1]}/.Trashes/$EUID"
-;; else
-;; mv_to_trash "$item" "$HOME/.Trash"
-;; fi
-;; fi
-;; done
+;; This file provide a redefinition of `dired-create-file' function,
+;; 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:
+
+;; (dired-async-mode 1)
+
+;; This will enable async copy/rename etc...
+;; in dired and helm.
;;; Code:
\f
+(require 'cl-lib)
(require 'dired-aux)
(require 'async)
-(require 'async-file)
+
+(eval-when-compile
+ (defvar async-callback))
+(defvar dired-async-operation nil)
(defgroup dired-async nil
- "Copy/move/delete asynchronously in dired"
+ "Copy rename files asynchronously from dired."
:group 'dired)
-(defface dired-async-in-process-face
- '((t (:background "yellow")))
- "Face used to show that an asynchronous operation is in progress."
+(defcustom dired-async-env-variables-regexp
+ "\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*"
+ "Variables matching this regexp will be loaded on Child Emacs."
+ :type 'regexp
:group 'dired-async)
-(defvar dired-async-queue nil
- "Queue of pending asynchronous file operations.
-Each operation that succeeds will start the next member of the queue. If an
-error occurs at any point, the rest of the queue is flushed.")
-
-(defvar dired-async-use-native-commands nil
- "If non-nil, use native commands like `rm' and `mv' for file operations. Otherwise use elisp.")
-
-(defun dired-async-highlight-file (file)
- (save-excursion
- (dired-goto-file file)
- (let ((overlay (make-overlay (line-beginning-position)
- (line-end-position))))
- (overlay-put overlay 'face 'dired-async-in-process-face)
- overlay)))
-
-(defun dired-async-remove-highlight (overlay)
- (delete-overlay overlay))
+(defcustom dired-async-message-function 'dired-async-mode-line-message
+ "Function to use to notify result when operation finish.
+Should take same args as `message'."
+ :group 'dired-async
+ :type 'function)
-(defun dired-after-file-create (to actual-marker-char &optional overwrite)
- (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))
- (dired-add-file to actual-marker-char))
+(defcustom dired-async-log-file "/tmp/dired-async.log"
+ "File use to communicate errors from Child Emacs to host Emacs."
+ :group 'dired-async
+ :type 'string)
-(eval-when-compile
- (defvar actual-marker-char)
- (defvar overwrite)
- (defvar async-callback))
-
-(defmacro dired-async-wrap-call (file callback forms)
- `(let ((overlay (dired-async-highlight-file ,file)))
- ,(if callback
- `(setq ,callback `(lambda (ret)
- (dired-async-remove-highlight ,overlay)
- (funcall ,,callback ret))))
- ,forms))
-
-(put 'dired-async-wrap-call 'lisp-indent-function 2)
-
-(defun dired-copy-file-recursive (from to ok-flag &optional
- preserve-time top recursive)
- (when (and (eq t (car (file-attributes from)))
- (file-in-directory-p to from))
- (error "Cannot copy `%s' into its subdirectory `%s'" from to))
- (let ((attrs (file-attributes from))
- (callback (if (boundp 'actual-marker-char)
- `(lambda (&optional ignore)
- (dired-after-file-create ,to ,actual-marker-char
- ,overwrite))
- (lambda (&optional ignore)))))
- (if (and recursive
- (eq t (car attrs))
- (or (eq recursive 'always)
- (yes-or-no-p (format "Recursive copies of %s? " from))))
- ;; This is a directory.
- (dired-async-wrap-call from callback
- (async-copy-file from to ok-flag preserve-time nil nil
- :callback callback))
- ;; Not a directory.
- (or top (dired-handle-overwrite to))
- (condition-case err
- (if (stringp (car attrs))
- ;; It is a symlink
- (make-symbolic-link (car attrs) to ok-flag)
- (dired-async-wrap-call from callback
- (async-copy-file from to ok-flag preserve-time nil nil
- :callback callback)))
- (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))))))
+(defface dired-async-message
+ '((t (:foreground "yellow")))
+ "Face used for mode-line message."
+ :group 'dired-async)
-(defun dired-rename-file (file newname ok-if-already-exists)
- (dired-handle-overwrite newname)
- (let ((callback
- (if (boundp 'actual-marker-char)
- `(lambda (&optional ignore)
- ;; Silently rename the visited file of any buffer visiting this
- ;; file.
- (and (get-file-buffer ,file)
- (with-current-buffer (get-file-buffer ,file)
- (set-visited-file-name ,newname nil t)))
- (dired-remove-file ,file)
- ;; See if it's an inserted subdir, and rename that, too.
- (dired-rename-subdir ,file ,newname)
+(defface dired-async-mode-message
+ '((t (:foreground "Gold")))
+ "Face used for `dired-async--modeline-mode' lighter."
+ :group 'dired-async)
- (dired-after-file-create ,newname ,actual-marker-char
- ,overwrite))
- (lambda (&optional ignore)))))
- (if (and dired-async-use-native-commands
- (not (file-remote-p file))
- (not (file-remote-p newname)))
- (let ((args (list "-f" file newname)))
- (unless ok-if-already-exists
- (setq args (cons "-n" args)))
- (apply #'async-start-process "mv" (executable-find "mv")
- callback args))
- (dired-async-wrap-call file callback
- (async-start (apply-partially #'rename-file file newname
- ok-if-already-exists)
- callback)))))
+(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--modeline-mode
+ (let ((visible-bell t)) (ding))))
-(defun dired-delete-file (file &optional recursive trash) "\
-Delete FILE or directory (possibly recursively if optional RECURSIVE is true.)
-RECURSIVE determines what to do with a non-empty directory. If RECURSIVE is:
-nil, do not delete.
-`always', delete recursively without asking.
-`top', ask for each directory at top level.
-Anything else, ask for each sub-directory."
- ;; This test is equivalent to
- ;; (and (file-directory-p fn) (not (file-symlink-p fn)))
- ;; but more efficient
- (if (not (eq t (car (file-attributes file))))
- (dired-async-wrap-call file nil
- (cond
- ;; How to reliably trash files on other systems? Use Emacs to do it
- (trash
- (async-start-process "rmtrash" (executable-find "rmtrash")
- 'ignore "-f" file))
- ((and (not trash) dired-async-use-native-commands
- (not (file-remote-p file)))
- (async-start-process "rm" (executable-find "rm") 'ignore "-f" file))
- (t
- (async-start (apply-partially #'delete-file file trash)
- 'ignore))))
- (if (and recursive
- (directory-files file t dired-re-no-dot) ; Not empty.
- (or (eq recursive 'always)
- (yes-or-no-p (format "Recursively %s %s? "
- (if (and trash
- delete-by-moving-to-trash)
- "trash"
- "delete")
- (dired-make-relative file)))))
- (if (eq recursive 'top) (setq recursive 'always)) ; Don't ask again.
- (setq recursive nil))
- (dired-async-wrap-call file nil
- (if (and dired-async-use-native-commands
- (not (file-remote-p file)))
- (if recursive
- (if trash
- (async-start-process "rmtrash" (executable-find "rmtrash")
- 'ignore "-fr" file)
- (async-start-process "rm" (executable-find "rm")
- 'ignore "-fr" file))
- (async-start-process "rmdir" (executable-find "rmdir")
- 'ignore file))
- (async-start (apply-partially #'delete-directory file recursive trash)
- 'ignore)))))
+(defun dired-async-mode-line-message (text &rest args)
+ "Notify end of operation in `mode-line'."
+ (message nil)
+ (let ((mode-line-format (concat
+ " " (propertize
+ (if args
+ (apply #'format text args)
+ text)
+ 'face 'dired-async-message))))
+ (force-mode-line-update)
+ (sit-for 3)
+ (force-mode-line-update)))
-(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.
+(defun dired-async-processes ()
+ (cl-loop for p in (process-list)
+ when (cl-loop for c in (process-command p) thereis
+ (string= "async-batch-invoke" c))
+ collect p))
-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'.
+(defun dired-async-kill-process ()
+ (interactive)
+ (let* ((processes (dired-async-processes))
+ (proc (car (last processes))))
+ (and proc (delete-process proc))
+ (unless (> (length processes) 1)
+ (dired-async--modeline-mode -1))))
-OPERATION should be a capitalized string describing the operation
-performed (e.g. `Copy'). It is used for error logging.
+(defun dired-async-after-file-create (len-flist)
+ "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--modeline-mode -1))
+ (when dired-async-operation
+ (if (file-exists-p dired-async-log-file)
+ (progn
+ (pop-to-buffer (get-buffer-create "*dired async*"))
+ (erase-buffer)
+ (insert "Error: ")
+ (insert-file-contents dired-async-log-file)
+ (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))))
-FN-LIST is the list of files to copy (full absolute file names).
+(defun dired-async-maybe-kill-ftp ()
+ "Return a form to kill ftp process in child emacs."
+ (quote
+ (progn
+ (require 'cl-lib)
+ (let ((buf (cl-loop for b in (buffer-list)
+ thereis (and (string-match
+ "\\`\\*ftp.*"
+ (buffer-name b)) b))))
+ (when buf (kill-buffer buf))))))
-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.
+(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.
-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."
- (let (dired-create-files-failures
- failures skipped (success-count 0) (total (length fn-list)))
- (let (to overwrite-query
- overwrite-backup-query) ; for dired-handle-overwrite
+See `dired-create-files' for the behavior of arguments."
+ (setq dired-async-operation nil)
+ (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)))
- (condition-case err
- (funcall file-creator from to dired-overwrite-confirmed)
- (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 proceeding asynchronously..." operation)))))
+ (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"
+ operation from to)))
+ (push (cons from to) async-fn-list)))))
+ (setq callback
+ `(lambda (&optional ignore)
+ (dired-async-after-file-create ,total)
+ (when (string= ,(downcase operation) "rename")
+ (cl-loop for (file . to) in ',async-fn-list
+ do (and (get-file-buffer file)
+ (with-current-buffer (get-file-buffer file)
+ (set-visited-file-name to nil t))))))))
+ ;; Handle error happening in host emacs.
+ (cond (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)))
+ ;; Start async process.
+ (when async-fn-list
+ (async-start `(lambda ()
+ (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))
+ (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--modeline-mode 1)
+ (setq dired-async-operation (list operation (length async-fn-list)))
+ (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))))
-(defun dired-internal-do-deletions (l arg &optional trash)
- ;; L is an alist of files to delete, with their buffer positions.
- ;; ARG is the prefix arg.
- ;; Filenames are absolute.
- ;; (car L) *must* be the *last* (bottommost) file in the dired buffer.
- ;; That way as changes are made in the buffer they do not shift the
- ;; lines still to be changed, so the (point) values in L stay valid.
- ;; Also, for subdirs in natural order, a subdir's files are deleted
- ;; before the subdir itself - the other way around would not work.
- (let* ((files (mapcar (function car) l))
- (count (length l))
- (succ 0)
- (trashing (and trash delete-by-moving-to-trash))
- (progress-reporter
- (make-progress-reporter
- (if trashing "Trashing..." "Deleting...")
- succ count)))
- ;; canonicalize file list for pop up
- (setq files (nreverse (mapcar (function dired-make-relative) files)))
- (if (dired-mark-pop-up
- " *Deletions*" 'delete files dired-deletion-confirmer
- (format "%s %s "
- (if trashing "Trash" "Delete")
- (dired-mark-prompt arg files)))
- (save-excursion
- (let (failures);; files better be in reverse order for this loop!
- (while l
- (goto-char (cdr (car l)))
- (let ((inhibit-read-only t))
- (condition-case err
- (let ((fn (car (car l))))
- (dired-delete-file fn dired-recursive-deletes trash)
- ;; if we get here, removing worked
- (setq succ (1+ succ))
- (progress-reporter-update progress-reporter succ)
- (dired-fun-in-all-buffers
- (file-name-directory fn) (file-name-nondirectory fn)
- (function dired-delete-entry) fn))
- (error;; catch errors from failed deletions
- (dired-log "%s\n" err)
- (setq failures (cons (car (car l)) failures)))))
- (setq l (cdr l)))
- (if (not failures)
- (progress-reporter-done progress-reporter)
- (dired-log-summary
- (format "%d of %d deletion%s failed"
- (length failures) count
- (dired-plural-s count))
- failures))))
- (message "(No deletions performed)"))))
(provide 'dired-async)