X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/e35506faac6315da3c25b72682c99210b2d0bb28..dd09794572d1d3c1d6d277ac31b4c6d67d7fda93:/dired-async.el diff --git a/dired-async.el b/dired-async.el index 418f265e9..c6ff0b9e3 100644 --- a/dired-async.el +++ b/dired-async.el @@ -44,7 +44,6 @@ (eval-when-compile (defvar async-callback)) -(defvar dired-async-operation nil) (defgroup dired-async nil "Copy rename files asynchronously from dired." @@ -72,6 +71,11 @@ Should take same args as `message'." "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 (:foreground "Gold"))) "Face used for `dired-async--modeline-mode' lighter." @@ -87,7 +91,7 @@ Should take same args as `message'." (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 @@ -95,7 +99,7 @@ Should take same args as `message'." (if args (apply #'format text args) text) - 'face 'dired-async-message)))) + 'face face)))) (force-mode-line-update) (sit-for 3) (force-mode-line-update))) @@ -114,24 +118,45 @@ Should take same args as `message'." (unless (> (length processes) 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--modeline-mode -1)) - (when dired-async-operation + (when operation (if (file-exists-p dired-async-log-file) (progn - (pop-to-buffer (get-buffer-create "*dired async*")) - (erase-buffer) + (pop-to-buffer (get-buffer-create dired-log-buffer)) + (goto-char (point-max)) + (setq inhibit-read-only t) (insert "Error: ") (insert-file-contents dired-async-log-file) + (special-mode) + (shrink-window-if-larger-than-buffer) (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 on %s file%s done" + 'dired-async-message + (car operation) (cadr operation) + total (dired-plural-s total))))))) (defun dired-async-maybe-kill-ftp () "Return a form to kill ftp process in child emacs." @@ -150,7 +175,6 @@ Should take same args as `message'." "Same as `dired-create-files' but asynchronous. See `dired-create-files' for the behavior of arguments." - (setq dired-async-operation nil) (setq overwrite-query nil) (let ((total (length fn-list)) failures async-fn-list skipped callback) @@ -168,11 +192,11 @@ See `dired-create-files' for the behavior of arguments." (file-exists-p to))) (dired-overwrite-confirmed ; for dired-handle-overwrite (and overwrite - (let ((help-form '(format "\ + (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))) +`!' 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 @@ -205,30 +229,40 @@ ESC or `q' to not overwrite any of the remaining files, (push (cons from to) async-fn-list)) (progn (push (dired-make-relative from) failures) - (dired-log "%s `%s' to `%s' failed" + (dired-log "%s `%s' to `%s' failed\n" operation from to))) (push (cons from to) async-fn-list))))) + ;; When failures have been printed to dired log add the date at bob. + (when (or failures skipped) (dired-log t)) + ;; 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) - (when (string= ,(downcase operation) "rename") - (cl-loop for (file . to) in ',async-fn-list - do (and (get-file-buffer file) - (with-current-buffer (get-file-buffer file) + (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) + for destp = (file-exists-p to) + do (and bf destp + (with-current-buffer bf (set-visited-file-name to nil t)))))))) - ;; Handle error happening in host emacs. - (cond (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))) ;; Start async process. (when async-fn-list (async-start `(lambda () @@ -257,21 +291,21 @@ ESC or `q' to not overwrite any of the remaining files, (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-log "%s: %s\n" (car err) (cdr err)) + (dired-log t) + (with-current-buffer dired-log-buffer + (write-region (point-min) (point-max) + ,dired-async-log-file)))) ,(dired-async-maybe-kill-ftp)) callback) ;; Run mode-line notifications while process running. (dired-async--modeline-mode 1) - (setq dired-async-operation (list operation (length async-fn-list))) (message "%s proceeding asynchronously..." operation)))) (defadvice dired-create-files (around dired-async)