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