| 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 | |
