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

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