Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

408 lines
17 KiB

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