X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/b311374bfc5e359c0ca31b804b1c1c1fe579dcc3..8d1a26de6c716127b67d3b0c6808d5beeb13bba2:/dired-async.el diff --git a/dired-async.el b/dired-async.el index dec88ed27..d7377a90d 100644 --- a/dired-async.el +++ b/dired-async.el @@ -1,12 +1,10 @@ -;;; dired-async.el --- Copy/move/delete asynchronously in dired. +;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*- -;; Copyright (C) 2012~2013 John Wiegley -;; Copyright (C) 2012~2013 Thierry Volpiatto +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; Authors: John Wiegley ;; Thierry Volpiatto -;; Version: 1.0 ;; Keywords: dired async network ;; X-URL: https://github.com/jwiegley/dired-async @@ -28,15 +26,15 @@ ;;; Commentary: ;; This file provide a redefinition of `dired-create-file' function, -;; which must be loaded *after* dired-aux.el, performs copies, -;; moves and all what is handled by `dired-create-file' in the background -;; using a slave Emacs process, by means of the async.el module. +;; performs copies, moves and all what is handled by `dired-create-file' +;; 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)) -;; -;; + +;; (dired-async-mode 1) + +;; This will enable async copy/rename etc... +;; in dired and helm. ;;; Code: @@ -46,7 +44,6 @@ (eval-when-compile (defvar async-callback)) -(defvar dired-async-operation nil) (defgroup dired-async nil "Copy rename files asynchronously from dired." @@ -69,35 +66,32 @@ Should take same args as `message'." :group 'dired-async :type 'string) -(defcustom dired-async-be-async t - "When non--nil make `dired-create-file' async. -This allow to turn off async features provided to this package." - :group 'dired-async - :type 'boolean) - -(defvaralias 'helm-async-be-async 'dired-async-be-async) - (defface dired-async-message '((t (:foreground "yellow"))) "Face used for mode-line message." :group 'dired-async) +(defface dired-async-failures + '((t (:foreground "red"))) + "Face used for mode-line message." + :group 'dired-async) + (defface dired-async-mode-message - '((t (:background "Firebrick1"))) - "Face used for `dired-async-mode' lighter." + '((t (:foreground "Gold"))) + "Face used for `dired-async--modeline-mode' lighter." :group 'dired-async) -(define-minor-mode dired-async-mode +(define-minor-mode dired-async--modeline-mode "Notify mode-line that an async process run." :group 'dired-async :global t :lighter (:eval (propertize (format " [%s Async job(s) running]" (length (dired-async-processes))) 'face 'dired-async-mode-message)) - (unless dired-async-mode + (unless dired-async--modeline-mode (let ((visible-bell t)) (ding)))) -(defun dired-async-mode-line-message (text &rest args) +(defun dired-async-mode-line-message (text face &rest args) "Notify end of operation in `mode-line'." (message nil) (let ((mode-line-format (concat @@ -105,7 +99,7 @@ This allow to turn off async features provided to this package." (if args (apply #'format text args) text) - 'face 'dired-async-message)))) + 'face face)))) (force-mode-line-update) (sit-for 3) (force-mode-line-update))) @@ -120,17 +114,17 @@ This allow to turn off async features provided to this package." (interactive) (let* ((processes (dired-async-processes)) (proc (car (last processes)))) - (delete-process proc) + (and proc (delete-process proc)) (unless (> (length processes) 1) - (dired-async-mode -1)))) + (dired-async--modeline-mode -1)))) -(defun dired-async-after-file-create (len-flist) +(defun dired-async-after-file-create (total operation failures skipped) "Callback function used for operation handled by `dired-create-file'." (unless (dired-async-processes) ;; Turn off mode-line notification ;; only when last process end. - (dired-async-mode -1)) - (when dired-async-operation + (dired-async--modeline-mode -1)) + (when operation (if (file-exists-p dired-async-log-file) (progn (pop-to-buffer (get-buffer-create "*dired async*")) @@ -140,8 +134,25 @@ This allow to turn off async features provided to this package." (delete-file dired-async-log-file)) (run-with-timer 0.1 nil - dired-async-message-function "Asynchronous %s of %s file(s) on %s file(s) done" - (car dired-async-operation) (cadr dired-async-operation) len-flist)))) + (lambda () + ;; First send error messages. + (cond (failures + (funcall dired-async-message-function + "%s failed for %d of %d file%s" + 'dired-async-failures + (car operation) (length failures) + total (dired-plural-s total))) + (skipped + (funcall dired-async-message-function + "%s: %d of %d file%s skipped" + 'dired-async-failures + (car operation) (length skipped) total + (dired-plural-s total)))) + ;; Finally send the success message. + (funcall dired-async-message-function + "Asynchronous %s of %s file(s) on %s file(s) done" + 'dired-async-message + (car operation) (cadr operation) total)))))) (defun dired-async-maybe-kill-ftp () "Return a form to kill ftp process in child emacs." @@ -154,37 +165,16 @@ This allow to turn off async features provided to this package." (buffer-name b)) b)))) (when buf (kill-buffer buf)))))) -(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. +(defvar overwrite-query) +(defun dired-async-create-files (file-creator operation fn-list name-constructor + &optional _marker-char) + "Same as `dired-create-files' but asynchronous. -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." - (setq dired-async-operation nil) - (let (dired-create-files-failures failures async-fn-list - skipped (success-count 0) (total (length fn-list)) - (callback `(lambda (&optional ignore) - (dired-async-after-file-create ,(length fn-list))))) - (let (to overwrite-query - overwrite-backup-query) ; for dired-handle-overwrite +See `dired-create-files' for the behavior of arguments." + (setq overwrite-query nil) + (let ((total (length fn-list)) + failures async-fn-list skipped callback) + (let (to) (dolist (from fn-list) (setq to (funcall name-constructor from)) (if (equal to from) @@ -194,118 +184,137 @@ old file was marked." (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 "\ + (let* ((overwrite (and (null (eq file-creator 'backup-file)) + (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))) - (if dired-async-be-async - (if overwrite - (or (and dired-overwrite-confirmed - (push (cons from to) async-fn-list)) - (progn - (push (dired-make-relative from) failures) - (dired-log "%s `%s' to `%s' failed" - operation from to))) - (push (cons from to) async-fn-list)) - (condition-case err - (progn - (funcall file-creator from to dired-overwrite-confirmed) - (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)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" operation success-count total) - (dired-add-file to actual-marker-char)) - (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))))))))) - ;; Handle error happening in host emacs. - (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: %s file%s" - operation success-count (dired-plural-s success-count)))) +`!' to overwrite all remaining files with no more questions." ,to))) + (dired-query 'overwrite-query "Overwrite `%s'?" to))))) + ;; 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))) + (if overwrite + (or (and dired-overwrite-confirmed + (push (cons from to) async-fn-list)) + (progn + (push (dired-make-relative from) failures) + (dired-log "%s `%s' to `%s' failed\n" + operation from to))) + (push (cons from to) async-fn-list))))) + ;; When async-fn-list is empty that's mean only one file + ;; had to be copied and user finally answer NO. + ;; In this case async process will never start and callback + ;; will have no chance to run, so notify failures here. + (unless async-fn-list + (cond (failures + (funcall dired-async-message-function + "%s failed for %d of %d file%s" + 'dired-async-failures + operation (length failures) + total (dired-plural-s total))) + (skipped + (funcall dired-async-message-function + "%s: %d of %d file%s skipped" + 'dired-async-failures + operation (length skipped) total + (dired-plural-s total))))) + ;; Setup callback. + (setq callback + (lambda (&optional _ignore) + (dired-async-after-file-create + total (list operation (length async-fn-list)) failures skipped) + (when (string= (downcase operation) "rename") + (cl-loop for (file . to) in async-fn-list + for bf = (get-file-buffer file) + do (and bf (with-current-buffer bf + (set-visited-file-name to nil t)))))))) ;; Start async process. - (when (and async-fn-list dired-async-be-async) + (when async-fn-list (async-start `(lambda () - (require 'cl-lib) (require 'dired-aux) + (require 'cl-lib) (require 'dired-aux) (require 'dired-x) ,(async-inject-variables dired-async-env-variables-regexp) (condition-case err - (let ((dired-recursive-copies (quote always))) - (cl-loop for (f . d) in (quote ,async-fn-list) - do (funcall (quote ,file-creator) f d t))) + (let ((dired-recursive-copies (quote always)) + (dired-copy-preserve-time + ,dired-copy-preserve-time)) + (setq overwrite-backup-query nil) + ;; Inline `backup-file' as long as it is not + ;; available in emacs. + (defalias 'backup-file + ;; Same feature as "cp --backup=numbered from to" + ;; Symlinks are copied as file from source unlike + ;; `dired-copy-file' which is same as cp -d. + ;; Directories are omitted. + (lambda (from to ok) + (cond ((file-directory-p from) (ignore)) + (t (let ((count 0)) + (while (let ((attrs (file-attributes to))) + (and attrs (null (nth 0 attrs)))) + (cl-incf count) + (setq to (concat (file-name-sans-versions to) + (format ".~%s~" count))))) + (condition-case err + (copy-file from to ok dired-copy-preserve-time) + (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))))))) + ;; Now run the FILE-CREATOR function on files. + (cl-loop with fn = (quote ,file-creator) + for (from . dest) in (quote ,async-fn-list) + do (funcall fn from dest t))) (file-error (with-temp-file ,dired-async-log-file (insert (format "%S" err))))) ,(dired-async-maybe-kill-ftp)) callback) ;; Run mode-line notifications while process running. - (dired-async-mode 1) - (setq dired-async-operation (list operation (length async-fn-list))) - (message "%s proceeding asynchronously..." operation))) - (unless dired-async-be-async - (dired-move-to-filename))) + (dired-async--modeline-mode 1) + (message "%s proceeding asynchronously..." operation)))) + +(defadvice dired-create-files (around dired-async) + (dired-async-create-files file-creator operation fn-list + name-constructor marker-char)) + +;;;###autoload +(define-minor-mode dired-async-mode + "Do dired actions asynchronously." + :group 'dired-async + :global t + (if dired-async-mode + (if (fboundp 'advice-add) + (advice-add 'dired-create-files :override #'dired-async-create-files) + (ad-activate 'dired-create-files)) + (if (fboundp 'advice-remove) + (advice-remove 'dired-create-files #'dired-async-create-files) + (ad-deactivate 'dired-create-files)))) (provide 'dired-async)