code.delx.au - gnu-emacs-elpa/blob - packages/async/dired-async.el

   1 ;;; dired-async.el --- Copy/move/delete asynchronously in dired.
   2
   3 ;; Copyright (C) 2012~2014 John Wiegley
   4 ;; Copyright (C) 2012~2014 Thierry Volpiatto
   5
   6 ;; Authors: John Wiegley <jwiegley@gmail.com>
   7 ;;          Thierry Volpiatto <thierry.volpiatto@gmail.com>
   8
   9 ;; Keywords: dired async network
  10 ;; X-URL: https://github.com/jwiegley/dired-async
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26 \f
  27 ;;; Commentary:
  28
  29 ;; This file provide a redefinition of `dired-create-file' function,
  30 ;; performs copies, moves and all what is handled by `dired-create-file'
  31 ;; in the background using a slave Emacs process,
  32 ;; by means of the async.el module.
  33 ;; To use it, put this in your .emacs:
  34
  35 ;;     (dired-async-mode 1)
  36
  37 ;; This will enable async copy/rename etc...
  38 ;; in dired and helm.
  39
  40 ;;; Code:
  41 \f
  42 (require 'cl-lib)
  43 (require 'dired-aux)
  44 (require 'async)
  45
  46 (eval-when-compile
  47   (defvar async-callback))
  48 (defvar dired-async-operation nil)
  49
  50 (defgroup dired-async nil
  51   "Copy rename files asynchronously from dired."
  52   :group 'dired)
  53
  54 (defcustom dired-async-env-variables-regexp
  55   "\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*"
  56   "Variables matching this regexp will be loaded on Child Emacs."
  57   :type  'regexp
  58   :group 'dired-async)
  59
  60 (defcustom dired-async-message-function 'dired-async-mode-line-message
  61   "Function to use to notify result when operation finish.
  62 Should take same args as `message'."
  63   :group 'dired-async
  64   :type  'function)
  65
  66 (defcustom dired-async-log-file "/tmp/dired-async.log"
  67   "File use to communicate errors from Child Emacs to host Emacs."
  68   :group 'dired-async
  69   :type 'string)
  70
  71 (defface dired-async-message
  72     '((t (:foreground "yellow")))
  73   "Face used for mode-line message."
  74   :group 'dired-async)
  75
  76 (defface dired-async-mode-message
  77     '((t (:foreground "Gold")))
  78   "Face used for `dired-async--modeline-mode' lighter."
  79   :group 'dired-async)
  80
  81 (define-minor-mode dired-async--modeline-mode
  82     "Notify mode-line that an async process run."
  83   :group 'dired-async
  84   :global t
  85   :lighter (:eval (propertize (format " [%s Async job(s) running]"
  86                                       (length (dired-async-processes)))
  87                               'face 'dired-async-mode-message))
  88   (unless dired-async--modeline-mode
  89     (let ((visible-bell t)) (ding))))
  90
  91 (defun dired-async-mode-line-message (text &rest args)
  92   "Notify end of operation in `mode-line'."
  93   (message nil)
  94   (let ((mode-line-format (concat
  95                            " " (propertize
  96                                 (if args
  97                                     (apply #'format text args)
  98                                     text)
  99                                 'face 'dired-async-message))))
 100     (force-mode-line-update)
 101     (sit-for 3)
 102     (force-mode-line-update)))
 103
 104 (defun dired-async-processes ()
 105   (cl-loop for p in (process-list)
 106            when (cl-loop for c in (process-command p) thereis
 107                          (string= "async-batch-invoke" c))
 108            collect p))
 109
 110 (defun dired-async-kill-process ()
 111   (interactive)
 112   (let* ((processes (dired-async-processes))
 113          (proc (car (last processes))))
 114     (delete-process proc)
 115     (unless (> (length processes) 1)
 116       (dired-async--modeline-mode -1))))
 117
 118 (defun dired-async-after-file-create (len-flist)
 119   "Callback function used for operation handled by `dired-create-file'."
 120   (unless (dired-async-processes)
 121     ;; Turn off mode-line notification
 122     ;; only when last process end.
 123     (dired-async--modeline-mode -1))
 124   (when dired-async-operation
 125     (if (file-exists-p dired-async-log-file)
 126         (progn
 127           (pop-to-buffer (get-buffer-create "*dired async*"))
 128           (erase-buffer)
 129           (insert "Error: ")
 130           (insert-file-contents dired-async-log-file)
 131           (delete-file dired-async-log-file))
 132         (run-with-timer
 133          0.1 nil
 134          dired-async-message-function "Asynchronous %s of %s file(s) on %s file(s) done"
 135          (car dired-async-operation) (cadr dired-async-operation) len-flist))))
 136
 137 (defun dired-async-maybe-kill-ftp ()
 138   "Return a form to kill ftp process in child emacs."
 139   (quote
 140    (progn
 141      (require 'cl-lib)
 142      (let ((buf (cl-loop for b in (buffer-list)
 143                          thereis (and (string-match
 144                                        "\\`\\*ftp.*"
 145                                        (buffer-name b)) b))))
 146        (when buf (kill-buffer buf))))))
 147
 148 (defun dired-async-create-files (file-creator operation fn-list name-constructor
 149                                  &optional marker-char)
 150   "Same as `dired-create-files' but asynchronous.
 151
 152 See `dired-create-files' for the behavior of arguments."
 153   (setq dired-async-operation nil)
 154   (let (dired-create-files-failures
 155         failures async-fn-list
 156         skipped (success-count 0)
 157         (total (length fn-list))
 158         callback)
 159     (let (to overwrite-query
 160              overwrite-backup-query)    ; for dired-handle-overwrite
 161       (dolist (from fn-list)
 162         (setq to (funcall name-constructor from))
 163         (if (equal to from)
 164             (progn
 165               (setq to nil)
 166               (dired-log "Cannot %s to same file: %s\n"
 167                          (downcase operation) from)))
 168         (if (not to)
 169             (setq skipped (cons (dired-make-relative from) skipped))
 170             (let* ((overwrite (file-exists-p to))
 171                    (dired-overwrite-confirmed ; for dired-handle-overwrite
 172                     (and overwrite
 173                          (let ((help-form '(format "\
 174 Type SPC or `y' to overwrite file `%s',
 175 DEL or `n' to skip to next,
 176 ESC or `q' to not overwrite any of the remaining files,
 177 `!' to overwrite all remaining files with no more questions." to)))
 178                            (dired-query 'overwrite-query
 179                                         "Overwrite `%s'?" to))))
 180                    ;; must determine if FROM is marked before file-creator
 181                    ;; gets a chance to delete it (in case of a move).
 182                    (actual-marker-char
 183                     (cond  ((integerp marker-char) marker-char)
 184                            (marker-char (dired-file-marker from)) ; slow
 185                            (t nil))))
 186               ;; Handle the `dired-copy-file' file-creator specially
 187               ;; When copying a directory to another directory or
 188               ;; possibly to itself or one of its subdirectories.
 189               ;; e.g "~/foo/" => "~/test/"
 190               ;; or "~/foo/" =>"~/foo/"
 191               ;; or "~/foo/ => ~/foo/bar/")
 192               ;; In this case the 'name-constructor' have set the destination
 193               ;; TO to "~/test/foo" because the old emacs23 behavior
 194               ;; of `copy-directory' was to not create the subdirectory
 195               ;; and instead copy the contents.
 196               ;; With the new behavior of `copy-directory'
 197               ;; (similar to the `cp' shell command) we don't
 198               ;; need such a construction of the target directory,
 199               ;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
 200               (let ((destname (file-name-directory to)))
 201                 (when (and (file-directory-p from)
 202                            (file-directory-p to)
 203                            (eq file-creator 'dired-copy-file))
 204                   (setq to destname))
 205                 ;; If DESTNAME is a subdirectory of FROM, not a symlink,
 206                 ;; and the method in use is copying, signal an error.
 207                 (and (eq t (car (file-attributes destname)))
 208                      (eq file-creator 'dired-copy-file)
 209                      (file-in-directory-p destname from)
 210                      (error "Cannot copy `%s' into its subdirectory `%s'"
 211                             from to)))
 212               (if overwrite
 213                   (or (and dired-overwrite-confirmed
 214                            (push (cons from to) async-fn-list))
 215                       (progn
 216                         (push (dired-make-relative from) failures)
 217                         (dired-log "%s `%s' to `%s' failed"
 218                                    operation from to)))
 219                   (push (cons from to) async-fn-list)))))
 220       (setq callback
 221             `(lambda (&optional ignore)
 222                (dired-async-after-file-create ,total)
 223                (when (string= ,(downcase operation) "rename")
 224                  (cl-loop for (file . to) in ',async-fn-list
 225                           do (and (get-file-buffer file)
 226                                   (with-current-buffer (get-file-buffer file)
 227                                     (set-visited-file-name to nil t))))))))
 228     ;; Handle error happening in host emacs.
 229     (cond
 230       (dired-create-files-failures
 231        (setq failures (nconc failures dired-create-files-failures))
 232        (dired-log-summary
 233         (format "%s failed for %d file%s in %d requests"
 234                 operation (length failures)
 235                 (dired-plural-s (length failures))
 236                 total)
 237         failures))
 238       (failures
 239        (dired-log-summary
 240         (format "%s failed for %d of %d file%s"
 241                 operation (length failures)
 242                 total (dired-plural-s total))
 243         failures))
 244       (skipped
 245        (dired-log-summary
 246         (format "%s: %d of %d file%s skipped"
 247                 operation (length skipped) total
 248                 (dired-plural-s total))
 249         skipped))
 250       (t (message "%s: %s file%s"
 251                   operation success-count (dired-plural-s success-count))))
 252     ;; Start async process.
 253     (when async-fn-list
 254       (async-start `(lambda ()
 255                       (require 'cl-lib) (require 'dired-aux) (require 'dired-x)
 256                       ,(async-inject-variables dired-async-env-variables-regexp)
 257                       (condition-case err
 258                           (let ((dired-recursive-copies (quote always)))
 259                             (cl-loop for (f . d) in (quote ,async-fn-list)
 260                                      do (funcall (quote ,file-creator) f d t)))
 261                         (file-error
 262                          (with-temp-file ,dired-async-log-file
 263                            (insert (format "%S" err)))))
 264                       ,(dired-async-maybe-kill-ftp))
 265                    callback)
 266       ;; Run mode-line notifications while process running.
 267       (dired-async--modeline-mode 1)
 268       (setq dired-async-operation (list operation (length async-fn-list)))
 269       (message "%s proceeding asynchronously..." operation))))
 270
 271 (defadvice dired-create-files (around dired-async)
 272   (dired-async-create-files file-creator operation fn-list
 273                             name-constructor marker-char))
 274
 275 ;;;###autoload
 276 (define-minor-mode dired-async-mode
 277     "Do dired actions asynchronously."
 278   :group 'dired-async
 279   :global t
 280   (if dired-async-mode
 281       (if (fboundp 'advice-add)
 282           (advice-add 'dired-create-files :override #'dired-async-create-files)
 283           (ad-activate 'dired-create-files))
 284       (if (fboundp 'advice-remove)
 285           (advice-remove 'dired-create-files #'dired-async-create-files)
 286           (ad-deactivate 'dired-create-files))))
 287
 288
 289 (provide 'dired-async)
 290
 291 ;;; dired-async.el ends here