;;; dired-async --- Copy/move/delete asynchronously in dired

;; Copyright (C) 2012~2013 John Wiegley

;; Author: John Wiegley <jwiegley@gmail.com>
;; 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))
;;
;; NOTE: If you have `delete-by-moving-to-trash' set to t, and you enable
;; `dired-async-use-native-commands', you will need to install the following
;; bash script on your system's PATH as "rmtrash".  Please edit to suit your
;; system.  It depends on the GNU realpath
;;
;; #!/bin/bash
;;
;; function mv_to_trash {
;;     path="$1"
;;     trash="$2"
;;
;;     if test -L "$path"; then
;;         rm -f "$path"           # don't trash symlinks, just remove them
;;     else
;;         target="$trash"/$(basename "$path")
;;         if test -e "$target"; then
;;             for (( index=$$ ; 1; index=index+1 )); do
;;                 target="$target"-"$index"
;;                 if ! test -e "$target"; then
;;                     break
;;                 fi
;;             done
;;         fi
;;         mv -f "$path" "$target" # don't worry about race-condition overwrites
;;     fi
;; }
;;
;; for item in "$@"; do
;;     if [[ -n "$item" && ${item:0:1} == '-' ]]; then
;;         continue
;;     elif ! test -e "$item"; then
;;         continue
;;     else
;;         target=$(realpath "$item")
;;         if [[ "$target" =~ ^/Volumes/([^/]+)/ ]]; then
;;             mv_to_trash "$item" "/Volumes/${BASH_REMATCH[1]}/.Trashes/$EUID"
;;         else
;;             mv_to_trash "$item" "$HOME/.Trash"
;;         fi
;;     fi
;; done

;;; Code:

(require 'dired-aux)
(require 'async)
(require 'async-file)

(defgroup dired-async nil
  "Copy/move/delete asynchronously in dired"
  :group 'dired)

(defface dired-async-in-process-face
  '((t (:background "yellow")))
  "Face used to show that an asynchronous operation is in progress."
  :group 'dired-async)

(defvar dired-async-queue nil
  "Queue of pending asynchronous file operations.
Each operation that succeeds will start the next member of the queue.  If an
error occurs at any point, the rest of the queue is flushed.")

(defvar dired-async-use-native-commands nil
  "If non-nil, use native commands like `rm' and `mv' for file operations. Otherwise use elisp.")

(defun dired-async-highlight-file (file)
  (save-excursion
    (dired-goto-file file)
    (let ((overlay (make-overlay (line-beginning-position)
                                 (line-end-position))))
      (overlay-put overlay 'face 'dired-async-in-process-face)
      overlay)))

(defun dired-async-remove-highlight (overlay)
  (delete-overlay overlay))

(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))

(defmacro dired-async-wrap-call (file callback forms)
  `(let ((overlay (dired-async-highlight-file ,file)))
     ,(if callback
          `(setq ,callback `(lambda (ret)
                              (dired-async-remove-highlight ,overlay)
                              (funcall ,,callback ret))))
     ,forms))

(put 'dired-async-wrap-call 'lisp-indent-function 2)

(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))
        (callback (if (boundp 'actual-marker-char)
                      `(lambda (&optional ignore)
                         (dired-after-file-create ,to ,actual-marker-char
                                                  ,overwrite))
                    (lambda (&optional ignore)))))
    (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.
        (dired-async-wrap-call from callback
          (async-copy-file from to ok-flag preserve-time nil nil
                           :callback callback))
      ;; 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)
            (dired-async-wrap-call from callback
              (async-copy-file from to ok-flag preserve-time nil nil
                               :callback callback)))
        (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)
  (let ((callback
         (if (boundp 'actual-marker-char)
             `(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))
           (lambda (&optional ignore)))))
    (if (and dired-async-use-native-commands
             (not (file-remote-p file))
             (not (file-remote-p newname)))
        (let ((args (list "-f" file newname)))
          (unless ok-if-already-exists
            (setq args (cons "-n" args)))
          (apply #'async-start-process "mv" (executable-find "mv")
                 callback args))
      (dired-async-wrap-call file callback
        (async-start (apply-partially #'rename-file file newname
                                      ok-if-already-exists)
                     callback)))))

(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))))
      (dired-async-wrap-call file nil
        (cond
         ;; How to reliably trash files on other systems?  Use Emacs to do it
         (trash
          (async-start-process "rmtrash" (executable-find "rmtrash")
                               'ignore "-f" file))
         ((and (not trash) dired-async-use-native-commands
               (not (file-remote-p file)))
          (async-start-process "rm" (executable-find "rm") 'ignore "-f" file))
         (t
          (async-start (apply-partially #'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))
    (dired-async-wrap-call file nil
      (if (and dired-async-use-native-commands
               (not (file-remote-p file)))
          (if recursive
              (if trash
                  (async-start-process "rmtrash" (executable-find "rmtrash")
                                       'ignore "-fr" file)
                (async-start-process "rm" (executable-find "rm")
                                     'ignore "-fr" file))
            (async-start-process "rmdir" (executable-find "rmdir")
                                 'ignore file))
        (async-start (apply-partially #'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