[elpa] master 728e791 005/187: Added dired-async

[Michael Albinus]

branch: master
commit 728e791de259b941ab9801c2012443037fb7d8c9
Author: John Wiegley <address@hidden>
Commit: John Wiegley <address@hidden>

    Added dired-async
---
 dired-async.el |  304 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 304 insertions(+), 0 deletions(-)

diff --git a/dired-async.el b/dired-async.el
new file mode 100644
index 0000000..02ee42a
--- /dev/null
+++ b/dired-async.el
@@ -0,0 +1,304 @@
+;;; dired-async --- Copy/move/delete asynchronously in dired
+
+;; Copyright (C) 2012 John Wiegley
+
+;; Author: John Wiegley <address@hidden>
+;; Created: 14 Jun 2012
+;; Version: 1.0
+;; Keywords: dired async network
+;; X-URL: https://github.com/jwiegley/dired-async
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; The function, which must be loaded *after* dired-aux.el, performs copies,
+;; moves and deletes in the background using a slave Emacs process, by means
+;; of the async.el module.  To use it, put this in your .emacs:
+;;
+;;   (eval-after-load "dired-aux"
+;;     '(require 'dired-async))
+
+;;; Code:
+
+(require 'dired-aux)
+(require 'async)
+
+(defgroup dired-async nil
+  "Copy/move/delete asynchronously in dired"
+  :group 'dired)
+
+(defun dired-after-file-create (to actual-marker-char &optional overwrite)
+  (if overwrite
+      ;; If we get here, file-creator hasn't been aborted
+      ;; and the old entry (if any) has to be deleted
+      ;; before adding the new entry.
+      (dired-remove-file to))
+  (dired-add-file to actual-marker-char))
+
+(eval-when-compile
+  (defvar actual-marker-char)
+  (defvar overwrite)
+  (defvar async-callback))
+
+(defun dired-copy-file-recursive (from to ok-flag &optional
+                                       preserve-time top recursive)
+  (when (and (eq t (car (file-attributes from)))
+             (file-in-directory-p to from))
+    (error "Cannot copy `%s' into its subdirectory `%s'" from to))
+  (let ((attrs (file-attributes from)))
+    (if (and recursive
+             (eq t (car attrs))
+             (or (eq recursive 'always)
+                 (yes-or-no-p (format "Recursive copies of %s? " from))))
+        ;; This is a directory.
+        (async-start
+         `(lambda ()
+            (copy-directory ,from ,to ,preserve-time))
+         `(lambda (&optional ignore)
+            (dired-after-file-create ,to ,actual-marker-char ,overwrite)))
+      ;; Not a directory.
+      (or top (dired-handle-overwrite to))
+      (condition-case err
+          (if (stringp (car attrs))
+              ;; It is a symlink
+              (make-symbolic-link (car attrs) to ok-flag)
+            (async-start
+             `(lambda ()
+                ;; jww (2012-06-18): Error gets absorbed if one happens at all
+                ;; right now.  I need to pass back the exception from the
+                ;; child process.
+                (copy-file ,from ,to ,ok-flag ,preserve-time))
+             `(lambda (&optional ignore)
+                (dired-after-file-create ,to ,actual-marker-char ,overwrite))))
+        (file-date-error
+         (push (dired-make-relative from)
+               dired-create-files-failures)
+         (dired-log "Can't set date on %s:\n%s\n" from err))))))
+
+(defun dired-rename-file (file newname ok-if-already-exists)
+  (dired-handle-overwrite newname)
+  (async-start
+   `(lambda ()
+      ;; error is caught in -create-files
+      (rename-file ,file ,newname ,ok-if-already-exists))
+   `(lambda (&optional ignore)
+      ;; Silently rename the visited file of any buffer visiting this file.
+      (and (get-file-buffer ,file)
+           (with-current-buffer (get-file-buffer ,file)
+             (set-visited-file-name ,newname nil t)))
+      (dired-remove-file ,file)
+      ;; See if it's an inserted subdir, and rename that, too.
+      (dired-rename-subdir ,file ,newname)
+
+      (dired-after-file-create ,newname ,actual-marker-char ,overwrite))))
+
+(defun dired-delete-file (file &optional recursive trash) "\
+Delete FILE or directory (possibly recursively if optional RECURSIVE is true.)
+RECURSIVE determines what to do with a non-empty directory.  If RECURSIVE is:
+nil, do not delete.
+`always', delete recursively without asking.
+`top', ask for each directory at top level.
+Anything else, ask for each sub-directory."
+  ;; This test is equivalent to
+  ;; (and (file-directory-p fn) (not (file-symlink-p fn)))
+  ;; but more efficient
+  (if (not (eq t (car (file-attributes file))))
+      (async-start
+       `(lambda ()
+          (delete-file ,file ,trash))
+       'ignore)
+    (if (and recursive
+             (directory-files file t dired-re-no-dot) ; Not empty.
+             (or (eq recursive 'always)
+                 (yes-or-no-p (format "Recursively %s %s? "
+                                      (if (and trash
+                                               delete-by-moving-to-trash)
+                                          "trash"
+                                        "delete")
+                                      (dired-make-relative file)))))
+        (if (eq recursive 'top) (setq recursive 'always)) ; Don't ask again.
+      (setq recursive nil))
+    (async-start
+     `(lambda ()
+        (delete-directory ,file ,recursive ,trash))
+     'ignore)))
+
+(defun dired-create-files (file-creator operation fn-list name-constructor
+                                        &optional marker-char)
+  "Create one or more new files from a list of existing files FN-LIST.
+This function also handles querying the user, updating Dired
+buffers, and displaying a success or failure message.
+
+FILE-CREATOR should be a function.  It is called once for each
+file in FN-LIST, and must create a new file, querying the user
+and updating Dired buffers as necessary.  It should accept three
+arguments: the old file name, the new name, and an argument
+OK-IF-ALREADY-EXISTS with the same meaning as in `copy-file'.
+
+OPERATION should be a capitalized string describing the operation
+performed (e.g. `Copy').  It is used for error logging.
+
+FN-LIST is the list of files to copy (full absolute file names).
+
+NAME-CONSTRUCTOR should be a function accepting a single
+argument, the name of an old file, and returning either the
+corresponding new file name or nil to skip.
+
+Optional MARKER-CHAR is a character with which to mark every
+newfile's entry, or t to use the current marker character if the
+old file was marked."
+  (let (dired-create-files-failures failures
+        skipped (success-count 0) (total (length fn-list)))
+    (let (to overwrite-query
+             overwrite-backup-query)   ; for dired-handle-overwrite
+      (dolist (from fn-list)
+        (setq to (funcall name-constructor from))
+        (if (equal to from)
+            (progn
+              (setq to nil)
+              (dired-log "Cannot %s to same file: %s\n"
+                         (downcase operation) from)))
+        (if (not to)
+            (setq skipped (cons (dired-make-relative from) skipped))
+          (let* ((overwrite (file-exists-p to))
+                 (dired-overwrite-confirmed ; for dired-handle-overwrite
+                  (and overwrite
+                       (let ((help-form '(format "\
+Type SPC or `y' to overwrite file `%s',
+DEL or `n' to skip to next,
+ESC or `q' to not overwrite any of the remaining files,
+`!' to overwrite all remaining files with no more questions." to)))
+                         (dired-query 'overwrite-query
+                                      "Overwrite `%s'?" to))))
+                 ;; must determine if FROM is marked before file-creator
+                 ;; gets a chance to delete it (in case of a move).
+                 (actual-marker-char
+                  (cond  ((integerp marker-char) marker-char)
+                         (marker-char (dired-file-marker from)) ; slow
+                         (t nil))))
+            ;; Handle the `dired-copy-file' file-creator specially
+            ;; When copying a directory to another directory or
+            ;; possibly to itself or one of its subdirectories.
+            ;; e.g "~/foo/" => "~/test/"
+            ;; or "~/foo/" =>"~/foo/"
+            ;; or "~/foo/ => ~/foo/bar/")
+            ;; In this case the 'name-constructor' have set the destination
+            ;; TO to "~/test/foo" because the old emacs23 behavior
+            ;; of `copy-directory' was to not create the subdirectory
+            ;; and instead copy the contents.
+            ;; With the new behavior of `copy-directory'
+            ;; (similar to the `cp' shell command) we don't
+            ;; need such a construction of the target directory,
+            ;; so modify the destination TO to "~/test/" instead of 
"~/test/foo/".
+            (let ((destname (file-name-directory to)))
+              (when (and (file-directory-p from)
+                         (file-directory-p to)
+                         (eq file-creator 'dired-copy-file))
+                (setq to destname))
+              ;; If DESTNAME is a subdirectory of FROM, not a symlink,
+              ;; and the method in use is copying, signal an error.
+              (and (eq t (car (file-attributes destname)))
+                   (eq file-creator 'dired-copy-file)
+                   (file-in-directory-p destname from)
+                   (error "Cannot copy `%s' into its subdirectory `%s'"
+                          from to)))
+            (condition-case err
+                (funcall file-creator from to dired-overwrite-confirmed)
+              (file-error              ; FILE-CREATOR aborted
+               (progn
+                 (push (dired-make-relative from)
+                       failures)
+                 (dired-log "%s `%s' to `%s' failed:\n%s\n"
+                            operation from to err))))))))
+    (cond
+     (dired-create-files-failures
+      (setq failures (nconc failures dired-create-files-failures))
+      (dired-log-summary
+       (format "%s failed for %d file%s in %d requests"
+                operation (length failures)
+                (dired-plural-s (length failures))
+                total)
+       failures))
+     (failures
+      (dired-log-summary
+       (format "%s failed for %d of %d file%s"
+                operation (length failures)
+                total (dired-plural-s total))
+       failures))
+     (skipped
+      (dired-log-summary
+       (format "%s: %d of %d file%s skipped"
+                operation (length skipped) total
+                (dired-plural-s total))
+       skipped))
+     (t
+      (message "%s proceeding asynchronously..." operation)))))
+
+(defun dired-internal-do-deletions (l arg &optional trash)
+  ;; L is an alist of files to delete, with their buffer positions.
+  ;; ARG is the prefix arg.
+  ;; Filenames are absolute.
+  ;; (car L) *must* be the *last* (bottommost) file in the dired buffer.
+  ;; That way as changes are made in the buffer they do not shift the
+  ;; lines still to be changed, so the (point) values in L stay valid.
+  ;; Also, for subdirs in natural order, a subdir's files are deleted
+  ;; before the subdir itself - the other way around would not work.
+  (let* ((files (mapcar (function car) l))
+         (count (length l))
+         (succ 0)
+         (trashing (and trash delete-by-moving-to-trash))
+         (progress-reporter
+          (make-progress-reporter
+           (if trashing "Trashing..." "Deleting...")
+           succ count)))
+    ;; canonicalize file list for pop up
+    (setq files (nreverse (mapcar (function dired-make-relative) files)))
+    (if (dired-mark-pop-up
+         " *Deletions*" 'delete files dired-deletion-confirmer
+         (format "%s %s "
+                 (if trashing "Trash" "Delete")
+                 (dired-mark-prompt arg files)))
+        (save-excursion
+          (let (failures);; files better be in reverse order for this loop!
+            (while l
+              (goto-char (cdr (car l)))
+              (let ((inhibit-read-only t))
+                (condition-case err
+                    (let ((fn (car (car l))))
+                      (dired-delete-file fn dired-recursive-deletes trash)
+                      ;; if we get here, removing worked
+                      (setq succ (1+ succ))
+                      (progress-reporter-update progress-reporter succ)
+                      (dired-fun-in-all-buffers
+                       (file-name-directory fn) (file-name-nondirectory fn)
+                       (function dired-delete-entry) fn))
+                  (error;; catch errors from failed deletions
+                   (dired-log "%s\n" err)
+                   (setq failures (cons (car (car l)) failures)))))
+              (setq l (cdr l)))
+            (if (not failures)
+                (progress-reporter-done progress-reporter)
+              (dired-log-summary
+               (format "%d of %d deletion%s failed"
+                       (length failures) count
+                       (dired-plural-s count))
+               failures))))
+      (message "(No deletions performed)"))))
+
+(provide 'dired-async)
+
+;;; dired-async.el ends here