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

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