X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/753d59324248357f2c4afdafe51364bc04460f52..2bfd6a0741cecfaacc83d69fb3e292c5f2053c53:/dired-async.el diff --git a/dired-async.el b/dired-async.el index 3f7d4d450..41f2b7955 100644 --- a/dired-async.el +++ b/dired-async.el @@ -1,7 +1,6 @@ ;;; dired-async.el --- Copy/move/delete asynchronously in dired. -;; Copyright (C) 2012~2014 John Wiegley -;; Copyright (C) 2012~2014 Thierry Volpiatto +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; Authors: John Wiegley ;; Thierry Volpiatto @@ -27,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: @@ -68,30 +67,24 @@ 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) - (defface dired-async-message '((t (:foreground "yellow"))) "Face used for mode-line message." :group 'dired-async) (defface dired-async-mode-message - '((t (:background "Firebrick1"))) - "Face used for `dired-async-modeline-mode' lighter." + '((t (:foreground "Gold"))) + "Face used for `dired-async--modeline-mode' lighter." :group 'dired-async) -(define-minor-mode dired-async-modeline-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-modeline-mode + (unless dired-async--modeline-mode (let ((visible-bell t)) (ding)))) (defun dired-async-mode-line-message (text &rest args) @@ -119,14 +112,14 @@ This allow to turn off async features provided to this package." (proc (car (last processes)))) (delete-process proc) (unless (> (length processes) 1) - (dired-async-modeline-mode -1)))) + (dired-async--modeline-mode -1)))) (defun dired-async-after-file-create (len-flist) "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)) + (dired-async--modeline-mode -1)) (when dired-async-operation (if (file-exists-p dired-async-log-file) (progn @@ -157,10 +150,11 @@ This allow to turn off async features provided to this package." See `dired-create-files' for the behavior of arguments." (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 (dired-create-files-failures + failures async-fn-list + skipped (success-count 0) + (total (length fn-list)) + callback) (let (to overwrite-query overwrite-backup-query) ; for dired-handle-overwrite (dolist (from fn-list) @@ -172,7 +166,8 @@ See `dired-create-files' for the behavior of arguments." (downcase operation) from))) (if (not to) (setq skipped (cons (dired-make-relative from) skipped)) - (let* ((overwrite (file-exists-p to)) + (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 "\ @@ -221,7 +216,15 @@ ESC or `q' to not overwrite any of the remaining files, (push (dired-make-relative from) failures) (dired-log "%s `%s' to `%s' failed" operation from to))) - (push (cons from to) async-fn-list)))))) + (push (cons from to) async-fn-list))))) + (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) + (set-visited-file-name to nil t)))))))) ;; Handle error happening in host emacs. (cond (dired-create-files-failures @@ -252,26 +255,60 @@ ESC or `q' to not overwrite any of the remaining files, (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)) + ;; 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-modeline-mode 1) + (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) + (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 'helm + :group 'dired-async :global t (if dired-async-mode - (advice-add 'dired-create-files :override #'dired-async-create-files) - (advice-remove 'dired-create-files #'dired-async-create-files))) + (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)