mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-21 e75a20334813452c6912c090d70a0de2c805f94d
commit | author | age
5cb5f7 1 ;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
C 2
3 ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
4
5 ;; Authors: John Wiegley <jwiegley@gmail.com>
6 ;;          Thierry Volpiatto <thierry.volpiatto@gmail.com>
7
8 ;; Keywords: dired async network
9 ;; X-URL: https://github.com/jwiegley/dired-async
10
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.
15
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.
20
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.
25
26 ;;; Commentary:
27
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:
33
34 ;;     (dired-async-mode 1)
35
36 ;; This will enable async copy/rename etc...
37 ;; in dired and helm.
38
39 ;;; Code:
40
41 (require 'cl-lib)
42 (require 'dired-aux)
43 (require 'async)
44
45 (eval-when-compile
46   (defvar async-callback))
47
48 (defgroup dired-async nil
49   "Copy rename files asynchronously from dired."
50   :group 'dired)
51
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."
55   :type  'regexp
56   :group 'dired-async)
57
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'."
61   :group 'dired-async
62   :type  'function)
63
64 (defcustom dired-async-log-file "/tmp/dired-async.log"
65   "File use to communicate errors from Child Emacs to host Emacs."
66   :group 'dired-async
67   :type 'string)
68
69 (defcustom dired-async-mode-lighter '(:eval
70                                       (when (eq major-mode 'dired-mode)
71                                         " Async"))
72   "Mode line lighter used for `dired-async-mode'."
73   :group 'dired-async
74   :risky t
75   :type 'sexp)
76
77 (defface dired-async-message
78     '((t (:foreground "yellow")))
79   "Face used for mode-line message."
80   :group 'dired-async)
81
82 (defface dired-async-failures
83     '((t (:foreground "red")))
84   "Face used for mode-line message."
85   :group 'dired-async)
86
87 (defface dired-async-mode-message
88     '((t (:foreground "Gold")))
89   "Face used for `dired-async--modeline-mode' lighter."
90   :group 'dired-async)
91
92 (define-minor-mode dired-async--modeline-mode
93     "Notify mode-line that an async process run."
94   :group 'dired-async
95   :global t
96   :lighter (:eval (propertize (format " [%s Async job(s) running]"
97                                       (length (dired-async-processes)))
98                               'face 'dired-async-mode-message))
99   (unless dired-async--modeline-mode
100     (let ((visible-bell t)) (ding))))
101
102 (defun dired-async-mode-line-message (text face &rest args)
103   "Notify end of operation in `mode-line'."
104   (message nil)
105   (let ((mode-line-format (concat
106                            " " (propertize
107                                 (if args
108                                     (apply #'format text args)
109                                     text)
110                                 'face face))))
111     (force-mode-line-update)
112     (sit-for 3)
113     (force-mode-line-update)))
114
115 (defun dired-async-processes ()
116   (cl-loop for p in (process-list)
117            when (cl-loop for c in (process-command p) thereis
118                          (string= "async-batch-invoke" c))
119            collect p))
120
121 (defun dired-async-kill-process ()
122   (interactive)
123   (let* ((processes (dired-async-processes))
124          (proc (car (last processes))))
125     (and proc (delete-process proc))
126     (unless (> (length processes) 1)
127       (dired-async--modeline-mode -1))))
128
129 (defun dired-async-after-file-create (total operation failures skipped)
130   "Callback function used for operation handled by `dired-create-file'."
131   (unless (dired-async-processes)
132     ;; Turn off mode-line notification
133     ;; only when last process end.
134     (dired-async--modeline-mode -1))
135   (when operation
136     (if (file-exists-p dired-async-log-file)
137         (progn
138           (pop-to-buffer (get-buffer-create dired-log-buffer))
139           (goto-char (point-max))
140           (setq inhibit-read-only t)
141           (insert "Error: ")
142           (insert-file-contents dired-async-log-file)
143           (special-mode)
144           (shrink-window-if-larger-than-buffer)
145           (delete-file dired-async-log-file))
146         (run-with-timer
147          0.1 nil
148          (lambda ()
149            ;; First send error messages.
150            (cond (failures
151                   (funcall dired-async-message-function
152                            "%s failed for %d of %d file%s -- See *Dired log* buffer"
153                            'dired-async-failures
154                            (car operation) (length failures)
155                            total (dired-plural-s total)))
156                  (skipped
157                   (funcall dired-async-message-function
158                            "%s: %d of %d file%s skipped -- See *Dired log* buffer"
159                            'dired-async-failures
160                            (car operation) (length skipped) total
161                            (dired-plural-s total))))
162            (when dired-buffers
163              (cl-loop for (_f . b) in dired-buffers
164                       when (buffer-live-p b)
165                       do (with-current-buffer b (revert-buffer nil t))))
166            ;; Finally send the success message.
167            (funcall dired-async-message-function
168                     "Asynchronous %s of %s on %s file%s done"
169                     'dired-async-message
170                     (car operation) (cadr operation)
171                     total (dired-plural-s total)))))))
172
173 (defun dired-async-maybe-kill-ftp ()
174   "Return a form to kill ftp process in child emacs."
175   (quote
176    (progn
177      (require 'cl-lib)
178      (let ((buf (cl-loop for b in (buffer-list)
179                          thereis (and (string-match
180                                        "\\`\\*ftp.*"
181                                        (buffer-name b)) b))))
182        (when buf (kill-buffer buf))))))
183
184 (defvar overwrite-query)
185 (defun dired-async-create-files (file-creator operation fn-list name-constructor
186                                  &optional _marker-char)
187   "Same as `dired-create-files' but asynchronous.
188
189 See `dired-create-files' for the behavior of arguments."
190   (setq overwrite-query nil)
191   (let ((total (length fn-list))
192         failures async-fn-list skipped callback
193         async-quiet-switch)
194     (let (to)
195       (dolist (from fn-list)
196         (setq to (funcall name-constructor from))
197         (if (and (equal to from)
198                  (null (eq file-creator 'backup-file)))
199             (progn
200               (setq to nil)
201               (dired-log "Cannot %s to same file: %s\n"
202                          (downcase operation) from)))
203         (if (not to)
204             (setq skipped (cons (dired-make-relative from) skipped))
205             (let* ((overwrite (and (null (eq file-creator 'backup-file))
206                                    (file-exists-p to)))
207                    (dired-overwrite-confirmed ; for dired-handle-overwrite
208                     (and overwrite
209                          (let ((help-form `(format "\
210 Type SPC or `y' to overwrite file `%s',
211 DEL or `n' to skip to next,
212 ESC or `q' to not overwrite any of the remaining files,
213 `!' to overwrite all remaining files with no more questions." ,to)))
214                            (dired-query 'overwrite-query "Overwrite `%s'?" to)))))
215               ;; Handle the `dired-copy-file' file-creator specially
216               ;; When copying a directory to another directory or
217               ;; possibly to itself or one of its subdirectories.
218               ;; e.g "~/foo/" => "~/test/"
219               ;; or "~/foo/" =>"~/foo/"
220               ;; or "~/foo/ => ~/foo/bar/")
221               ;; In this case the 'name-constructor' have set the destination
222               ;; TO to "~/test/foo" because the old emacs23 behavior
223               ;; of `copy-directory' was to not create the subdirectory
224               ;; and instead copy the contents.
225               ;; With the new behavior of `copy-directory'
226               ;; (similar to the `cp' shell command) we don't
227               ;; need such a construction of the target directory,
228               ;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
229               (let ((destname (file-name-directory to)))
230                 (when (and (file-directory-p from)
231                            (file-directory-p to)
232                            (eq file-creator 'dired-copy-file))
233                   (setq to destname))
234                 ;; If DESTNAME is a subdirectory of FROM, not a symlink,
235                 ;; and the method in use is copying, signal an error.
236                 (and (eq t (car (file-attributes destname)))
237                      (eq file-creator 'dired-copy-file)
238                      (file-in-directory-p destname from)
239                      (error "Cannot copy `%s' into its subdirectory `%s'"
240                             from to)))
241               (if overwrite
242                   (or (and dired-overwrite-confirmed
243                            (push (cons from to) async-fn-list))
244                       (progn
245                         (push (dired-make-relative from) failures)
246                         (dired-log "%s `%s' to `%s' failed\n"
247                                    operation from to)))
248                   (push (cons from to) async-fn-list)))))
249       ;; Fix tramp issue #80 with emacs-26, use "-q" only when needed.
250       (setq async-quiet-switch
251             (if (and (boundp 'tramp-cache-read-persistent-data)
252                      async-fn-list
253                      (cl-loop for (_from . to) in async-fn-list
254                               thereis (file-remote-p to)))
255                 "-q" "-Q"))
256       ;; When failures have been printed to dired log add the date at bob.
257       (when (or failures skipped) (dired-log t))
258       ;; When async-fn-list is empty that's mean only one file
259       ;; had to be copied and user finally answer NO.
260       ;; In this case async process will never start and callback
261       ;; will have no chance to run, so notify failures here.
262       (unless async-fn-list
263         (cond (failures
264                (funcall dired-async-message-function
265                         "%s failed for %d of %d file%s -- See *Dired log* buffer"
266                         'dired-async-failures
267                         operation (length failures)
268                         total (dired-plural-s total)))
269               (skipped
270                (funcall dired-async-message-function
271                         "%s: %d of %d file%s skipped -- See *Dired log* buffer"
272                         'dired-async-failures
273                         operation (length skipped) total
274                         (dired-plural-s total)))))
275       ;; Setup callback.
276       (setq callback
277             (lambda (&optional _ignore)
278                (dired-async-after-file-create
279                 total (list operation (length async-fn-list)) failures skipped)
280                (when (string= (downcase operation) "rename")
281                  (cl-loop for (file . to) in async-fn-list
282                           for bf = (get-file-buffer file)
283                           for destp = (file-exists-p to)
284                           do (and bf destp
285                                   (with-current-buffer bf
286                                     (set-visited-file-name to t t))))))))
287     ;; Start async process.
288     (when async-fn-list
289       (async-start `(lambda ()
290                       (require 'cl-lib) (require 'dired-aux) (require 'dired-x)
291                       ,(async-inject-variables dired-async-env-variables-regexp)
292                           (let ((dired-recursive-copies (quote always))
293                                 (dired-copy-preserve-time
294                                  ,dired-copy-preserve-time))
295                             (setq overwrite-backup-query nil)
296                             ;; Inline `backup-file' as long as it is not
297                             ;; available in emacs.
298                             (defalias 'backup-file
299                                 ;; Same feature as "cp -f --backup=numbered from to"
300                                 ;; Symlinks are copied as file from source unlike
301                                 ;; `dired-copy-file' which is same as cp -d.
302                                 ;; Directories are omitted.
303                                 (lambda (from to ok)
304                                   (cond ((file-directory-p from) (ignore))
305                                         (t (let ((count 0))
306                                              (while (let ((attrs (file-attributes to)))
307                                                       (and attrs (null (nth 0 attrs))))
308                                                (cl-incf count)
309                                                (setq to (concat (file-name-sans-versions to)
310                                                                 (format ".~%s~" count)))))
311                                            (condition-case err
312                                                (copy-file from to ok dired-copy-preserve-time)
313                                              (file-date-error
314                                               (dired-log "Can't set date on %s:\n%s\n" from err)))))))
315                             ;; Now run the FILE-CREATOR function on files.
316                             (cl-loop with fn = (quote ,file-creator)
317                                      for (from . dest) in (quote ,async-fn-list)
318                                      do (condition-case err
319                                             (funcall fn from dest t)
320                                           (file-error
321                                            (dired-log "%s: %s\n" (car err) (cdr err)))
322                                           nil))
323                         (when (get-buffer dired-log-buffer)
324                           (dired-log t)
325                           (with-current-buffer dired-log-buffer
326                            (write-region (point-min) (point-max)
327                                          ,dired-async-log-file))))
328                       ,(dired-async-maybe-kill-ftp))
329                    callback)
330       ;; Run mode-line notifications while process running.
331       (dired-async--modeline-mode 1)
332       (message "%s proceeding asynchronously..." operation))))
333
334 (defvar wdired-use-interactive-rename)
335 (defun dired-async-wdired-do-renames (old-fn &rest args)
336   ;; Perhaps a better fix would be to ask for renaming BEFORE starting
337   ;; OLD-FN when `wdired-use-interactive-rename' is non-nil.  For now
338   ;; just bind it to nil to ensure no questions will be asked between
339   ;; each rename.
340   (let (wdired-use-interactive-rename)
341     (apply old-fn args)))
342
343 (defadvice wdired-do-renames (around wdired-async)
344   (let (wdired-use-interactive-rename)
345     ad-do-it))
346
347 (defadvice dired-create-files (around dired-async)
348   (dired-async-create-files file-creator operation fn-list
349                             name-constructor marker-char))
350
351 ;;;###autoload
352 (define-minor-mode dired-async-mode
353   "Do dired actions asynchronously."
354   :group 'dired-async
355   :lighter dired-async-mode-lighter
356   :global t
357   (if dired-async-mode
358       (if (fboundp 'advice-add)
359           (progn (advice-add 'dired-create-files :override #'dired-async-create-files)
360                  (advice-add 'wdired-do-renames :around #'dired-async-wdired-do-renames))
361         (ad-activate 'dired-create-files)
362         (ad-activate 'wdired-do-renames))
363       (if (fboundp 'advice-remove)
364           (progn (advice-remove 'dired-create-files #'dired-async-create-files)
365                  (advice-remove 'wdired-do-renames #'dired-async-wdired-do-renames))
366           (ad-deactivate 'dired-create-files)
367           (ad-deactivate 'wdired-do-renames))))
368
369 (defmacro dired-async--with-async-create-files (&rest body)
370   "Evaluate BODY with ‘dired-create-files’ set to ‘dired-async-create-files’."
371   (declare (indent 0))
372   `(cl-letf (((symbol-function 'dired-create-files) #'dired-async-create-files))
373      ,@body))
374
375 ;;;###autoload
376 (defun dired-async-do-copy (&optional arg)
377   "Run ‘dired-do-copy’ asynchronously."
378   (interactive "P")
379   (dired-async--with-async-create-files
380     (dired-do-copy arg)))
381
382 ;;;###autoload
383 (defun dired-async-do-symlink (&optional arg)
384   "Run ‘dired-do-symlink’ asynchronously."
385   (interactive "P")
386   (dired-async--with-async-create-files
387     (dired-do-symlink arg)))
388
389 ;;;###autoload
390 (defun dired-async-do-hardlink (&optional arg)
391   "Run ‘dired-do-hardlink’ asynchronously."
392   (interactive "P")
393   (dired-async--with-async-create-files
394     (dired-do-hardlink arg)))
395
396 ;;;###autoload
397 (defun dired-async-do-rename (&optional arg)
398   "Run ‘dired-do-rename’ asynchronously."
399   (interactive "P")
400   (dired-async--with-async-create-files
401     (dired-do-rename arg)))
402
403 (provide 'dired-async)
404
405 ;;; dired-async.el ends here