1 ;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
3 ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
5 ;; Authors: John Wiegley <jwiegley@gmail.com>
6 ;; Thierry Volpiatto <thierry.volpiatto@gmail.com>
8 ;; Keywords: dired async network
9 ;; X-URL: https://github.com/jwiegley/dired-async
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; This file provide a redefinition of `dired-create-file' function,
29 ;; performs copies, moves and all what is handled by `dired-create-file'
30 ;; in the background using a slave Emacs process,
31 ;; by means of the async.el module.
32 ;; To use it, put this in your .emacs:
34 ;; (dired-async-mode 1)
36 ;; This will enable async copy/rename etc...
46 (defvar async-callback))
48 (defgroup dired-async nil
49 "Copy rename files asynchronously from dired."
52 (defcustom dired-async-env-variables-regexp
53 "\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*"
54 "Variables matching this regexp will be loaded on Child Emacs."
58 (defcustom dired-async-message-function 'dired-async-mode-line-message
59 "Function to use to notify result when operation finish.
60 Should take same args as `message'."
64 (defcustom dired-async-log-file "/tmp/dired-async.log"
65 "File use to communicate errors from Child Emacs to host Emacs."
69 (defface dired-async-message
70 '((t (:foreground "yellow")))
71 "Face used for mode-line message."
74 (defface dired-async-failures
75 '((t (:foreground "red")))
76 "Face used for mode-line message."
79 (defface dired-async-mode-message
80 '((t (:foreground "Gold")))
81 "Face used for `dired-async--modeline-mode' lighter."
84 (define-minor-mode dired-async--modeline-mode
85 "Notify mode-line that an async process run."
88 :lighter (:eval (propertize (format " [%s Async job(s) running]"
89 (length (dired-async-processes)))
90 'face 'dired-async-mode-message))
91 (unless dired-async--modeline-mode
92 (let ((visible-bell t)) (ding))))
94 (defun dired-async-mode-line-message (text face &rest args)
95 "Notify end of operation in `mode-line'."
97 (let ((mode-line-format (concat
100 (apply #'format text args)
103 (force-mode-line-update)
105 (force-mode-line-update)))
107 (defun dired-async-processes ()
108 (cl-loop for p in (process-list)
109 when (cl-loop for c in (process-command p) thereis
110 (string= "async-batch-invoke" c))
113 (defun dired-async-kill-process ()
115 (let* ((processes (dired-async-processes))
116 (proc (car (last processes))))
117 (and proc (delete-process proc))
118 (unless (> (length processes) 1)
119 (dired-async--modeline-mode -1))))
121 (defun dired-async-after-file-create (total operation failures skipped)
122 "Callback function used for operation handled by `dired-create-file'."
123 (unless (dired-async-processes)
124 ;; Turn off mode-line notification
125 ;; only when last process end.
126 (dired-async--modeline-mode -1))
128 (if (file-exists-p dired-async-log-file)
130 (pop-to-buffer (get-buffer-create dired-log-buffer))
131 (goto-char (point-max))
132 (setq inhibit-read-only t)
134 (insert-file-contents dired-async-log-file)
136 (shrink-window-if-larger-than-buffer)
137 (delete-file dired-async-log-file))
141 ;; First send error messages.
143 (funcall dired-async-message-function
144 "%s failed for %d of %d file%s -- See *Dired log* buffer"
145 'dired-async-failures
146 (car operation) (length failures)
147 total (dired-plural-s total)))
149 (funcall dired-async-message-function
150 "%s: %d of %d file%s skipped -- See *Dired log* buffer"
151 'dired-async-failures
152 (car operation) (length skipped) total
153 (dired-plural-s total))))
154 ;; Finally send the success message.
155 (funcall dired-async-message-function
156 "Asynchronous %s of %s on %s file%s done"
158 (car operation) (cadr operation)
159 total (dired-plural-s total)))))))
161 (defun dired-async-maybe-kill-ftp ()
162 "Return a form to kill ftp process in child emacs."
166 (let ((buf (cl-loop for b in (buffer-list)
167 thereis (and (string-match
169 (buffer-name b)) b))))
170 (when buf (kill-buffer buf))))))
172 (defvar overwrite-query)
173 (defun dired-async-create-files (file-creator operation fn-list name-constructor
174 &optional _marker-char)
175 "Same as `dired-create-files' but asynchronous.
177 See `dired-create-files' for the behavior of arguments."
178 (setq overwrite-query nil)
179 (let ((total (length fn-list))
180 failures async-fn-list skipped callback)
182 (dolist (from fn-list)
183 (setq to (funcall name-constructor from))
187 (dired-log "Cannot %s to same file: %s\n"
188 (downcase operation) from)))
190 (setq skipped (cons (dired-make-relative from) skipped))
191 (let* ((overwrite (and (null (eq file-creator 'backup-file))
193 (dired-overwrite-confirmed ; for dired-handle-overwrite
195 (let ((help-form `(format "\
196 Type SPC or `y' to overwrite file `%s',
197 DEL or `n' to skip to next,
198 ESC or `q' to not overwrite any of the remaining files,
199 `!' to overwrite all remaining files with no more questions." ,to)))
200 (dired-query 'overwrite-query "Overwrite `%s'?" to)))))
201 ;; Handle the `dired-copy-file' file-creator specially
202 ;; When copying a directory to another directory or
203 ;; possibly to itself or one of its subdirectories.
204 ;; e.g "~/foo/" => "~/test/"
205 ;; or "~/foo/" =>"~/foo/"
206 ;; or "~/foo/ => ~/foo/bar/")
207 ;; In this case the 'name-constructor' have set the destination
208 ;; TO to "~/test/foo" because the old emacs23 behavior
209 ;; of `copy-directory' was to not create the subdirectory
210 ;; and instead copy the contents.
211 ;; With the new behavior of `copy-directory'
212 ;; (similar to the `cp' shell command) we don't
213 ;; need such a construction of the target directory,
214 ;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
215 (let ((destname (file-name-directory to)))
216 (when (and (file-directory-p from)
217 (file-directory-p to)
218 (eq file-creator 'dired-copy-file))
220 ;; If DESTNAME is a subdirectory of FROM, not a symlink,
221 ;; and the method in use is copying, signal an error.
222 (and (eq t (car (file-attributes destname)))
223 (eq file-creator 'dired-copy-file)
224 (file-in-directory-p destname from)
225 (error "Cannot copy `%s' into its subdirectory `%s'"
228 (or (and dired-overwrite-confirmed
229 (push (cons from to) async-fn-list))
231 (push (dired-make-relative from) failures)
232 (dired-log "%s `%s' to `%s' failed\n"
234 (push (cons from to) async-fn-list)))))
235 ;; When failures have been printed to dired log add the date at bob.
236 (when (or failures skipped) (dired-log t))
237 ;; When async-fn-list is empty that's mean only one file
238 ;; had to be copied and user finally answer NO.
239 ;; In this case async process will never start and callback
240 ;; will have no chance to run, so notify failures here.
241 (unless async-fn-list
243 (funcall dired-async-message-function
244 "%s failed for %d of %d file%s -- See *Dired log* buffer"
245 'dired-async-failures
246 operation (length failures)
247 total (dired-plural-s total)))
249 (funcall dired-async-message-function
250 "%s: %d of %d file%s skipped -- See *Dired log* buffer"
251 'dired-async-failures
252 operation (length skipped) total
253 (dired-plural-s total)))))
256 (lambda (&optional _ignore)
257 (dired-async-after-file-create
258 total (list operation (length async-fn-list)) failures skipped)
259 (when (string= (downcase operation) "rename")
260 (cl-loop for (file . to) in async-fn-list
261 for bf = (get-file-buffer file)
262 for destp = (file-exists-p to)
264 (with-current-buffer bf
265 (set-visited-file-name to nil t))))))))
266 ;; Start async process.
268 (async-start `(lambda ()
269 (require 'cl-lib) (require 'dired-aux) (require 'dired-x)
270 ,(async-inject-variables dired-async-env-variables-regexp)
271 (let ((dired-recursive-copies (quote always))
272 (dired-copy-preserve-time
273 ,dired-copy-preserve-time))
274 (setq overwrite-backup-query nil)
275 ;; Inline `backup-file' as long as it is not
276 ;; available in emacs.
277 (defalias 'backup-file
278 ;; Same feature as "cp --backup=numbered from to"
279 ;; Symlinks are copied as file from source unlike
280 ;; `dired-copy-file' which is same as cp -d.
281 ;; Directories are omitted.
283 (cond ((file-directory-p from) (ignore))
285 (while (let ((attrs (file-attributes to)))
286 (and attrs (null (nth 0 attrs))))
288 (setq to (concat (file-name-sans-versions to)
289 (format ".~%s~" count)))))
291 (copy-file from to ok dired-copy-preserve-time)
293 (dired-log "Can't set date on %s:\n%s\n" from err)))))))
294 ;; Now run the FILE-CREATOR function on files.
295 (cl-loop with fn = (quote ,file-creator)
296 for (from . dest) in (quote ,async-fn-list)
297 do (condition-case err
298 (funcall fn from dest t)
300 (dired-log "%s: %s\n" (car err) (cdr err)))
302 (when (get-buffer dired-log-buffer)
304 (with-current-buffer dired-log-buffer
305 (write-region (point-min) (point-max)
306 ,dired-async-log-file))))
307 ,(dired-async-maybe-kill-ftp))
309 ;; Run mode-line notifications while process running.
310 (dired-async--modeline-mode 1)
311 (message "%s proceeding asynchronously..." operation))))
313 (defadvice dired-create-files (around dired-async)
314 (dired-async-create-files file-creator operation fn-list
315 name-constructor marker-char))
318 (define-minor-mode dired-async-mode
319 "Do dired actions asynchronously."
323 (if (fboundp 'advice-add)
324 (advice-add 'dired-create-files :override #'dired-async-create-files)
325 (ad-activate 'dired-create-files))
326 (if (fboundp 'advice-remove)
327 (advice-remove 'dired-create-files #'dired-async-create-files)
328 (ad-deactivate 'dired-create-files))))
331 (provide 'dired-async)
333 ;;; dired-async.el ends here