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

   1 ;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
   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 \f
  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 \f
  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 (defface dired-async-message
  70     '((t (:foreground "yellow")))
  71   "Face used for mode-line message."
  72   :group 'dired-async)
  73
  74 (defface dired-async-failures
  75     '((t (:foreground "red")))
  76   "Face used for mode-line message."
  77   :group 'dired-async)
  78
  79 (defface dired-async-mode-message
  80     '((t (:foreground "Gold")))
  81   "Face used for `dired-async--modeline-mode' lighter."
  82   :group 'dired-async)
  83
  84 (define-minor-mode dired-async--modeline-mode
  85     "Notify mode-line that an async process run."
  86   :group 'dired-async
  87   :global t
  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))))
  93
  94 (defun dired-async-mode-line-message (text face &rest args)
  95   "Notify end of operation in `mode-line'."
  96   (message nil)
  97   (let ((mode-line-format (concat
  98                            " " (propertize
  99                                 (if args
 100                                     (apply #'format text args)
 101                                     text)
 102                                 'face face))))
 103     (force-mode-line-update)
 104     (sit-for 3)
 105     (force-mode-line-update)))
 106
 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))
 111            collect p))
 112
 113 (defun dired-async-kill-process ()
 114   (interactive)
 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))))
 120
 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))
 127   (when operation
 128     (if (file-exists-p dired-async-log-file)
 129         (progn
 130           (pop-to-buffer (get-buffer-create dired-log-buffer))
 131           (goto-char (point-max))
 132           (setq inhibit-read-only t)
 133           (insert "Error: ")
 134           (insert-file-contents dired-async-log-file)
 135           (special-mode)
 136           (shrink-window-if-larger-than-buffer)
 137           (delete-file dired-async-log-file))
 138         (run-with-timer
 139          0.1 nil
 140          (lambda ()
 141            ;; First send error messages.
 142            (cond (failures
 143                   (funcall dired-async-message-function
 144                            "%s failed for %d of %d file%s"
 145                            'dired-async-failures
 146                            (car operation) (length failures)
 147                            total (dired-plural-s total)))
 148                  (skipped
 149                   (funcall dired-async-message-function
 150                            "%s: %d of %d file%s skipped"
 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"
 157                     'dired-async-message
 158                     (car operation) (cadr operation)
 159                     total (dired-plural-s total)))))))
 160
 161 (defun dired-async-maybe-kill-ftp ()
 162   "Return a form to kill ftp process in child emacs."
 163   (quote
 164    (progn
 165      (require 'cl-lib)
 166      (let ((buf (cl-loop for b in (buffer-list)
 167                          thereis (and (string-match
 168                                        "\\`\\*ftp.*"
 169                                        (buffer-name b)) b))))
 170        (when buf (kill-buffer buf))))))
 171
 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.
 176
 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)
 181     (let (to)
 182       (dolist (from fn-list)
 183         (setq to (funcall name-constructor from))
 184         (if (equal to from)
 185             (progn
 186               (setq to nil)
 187               (dired-log "Cannot %s to same file: %s\n"
 188                          (downcase operation) from)))
 189         (if (not to)
 190             (setq skipped (cons (dired-make-relative from) skipped))
 191             (let* ((overwrite (and (null (eq file-creator 'backup-file))
 192                                    (file-exists-p to)))
 193                    (dired-overwrite-confirmed ; for dired-handle-overwrite
 194                     (and 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))
 219                   (setq to destname))
 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'"
 226                             from to)))
 227               (if overwrite
 228                   (or (and dired-overwrite-confirmed
 229                            (push (cons from to) async-fn-list))
 230                       (progn
 231                         (push (dired-make-relative from) failures)
 232                         (dired-log "%s `%s' to `%s' failed\n"
 233                                    operation from to)))
 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
 242         (cond (failures
 243                (funcall dired-async-message-function
 244                         "%s failed for %d of %d file%s"
 245                         'dired-async-failures
 246                         operation (length failures)
 247                         total (dired-plural-s total)))
 248               (skipped
 249                (funcall dired-async-message-function
 250                         "%s: %d of %d file%s skipped"
 251                         'dired-async-failures
 252                         operation (length skipped) total
 253                         (dired-plural-s total)))))
 254       ;; Setup callback.
 255       (setq callback
 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)
 263                           do (and bf destp
 264                                   (with-current-buffer bf
 265                                     (set-visited-file-name to nil t))))))))
 266     ;; Start async process.
 267     (when async-fn-list
 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.
 282                                 (lambda (from to ok)
 283                                   (cond ((file-directory-p from) (ignore))
 284                                         (t (let ((count 0))
 285                                              (while (let ((attrs (file-attributes to)))
 286                                                       (and attrs (null (nth 0 attrs))))
 287                                                (cl-incf count)
 288                                                (setq to (concat (file-name-sans-versions to)
 289                                                                 (format ".~%s~" count)))))
 290                                            (condition-case err
 291                                                (copy-file from to ok dired-copy-preserve-time)
 292                                              (file-date-error
 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)
 299                                           (file-error
 300                                            (dired-log "%s: %s\n" (car err) (cdr err)))
 301                                           nil))
 302                         (when (get-buffer dired-log-buffer)
 303                           (dired-log t)
 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))
 308                    callback)
 309       ;; Run mode-line notifications while process running.
 310       (dired-async--modeline-mode 1)
 311       (message "%s proceeding asynchronously..." operation))))
 312
 313 (defadvice dired-create-files (around dired-async)
 314   (dired-async-create-files file-creator operation fn-list
 315                             name-constructor marker-char))
 316
 317 ;;;###autoload
 318 (define-minor-mode dired-async-mode
 319     "Do dired actions asynchronously."
 320   :group 'dired-async
 321   :global t
 322   (if dired-async-mode
 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))))
 329
 330
 331 (provide 'dired-async)
 332
 333 ;;; dired-async.el ends here