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