From: Michael Albinus Date: Wed, 30 Dec 2015 11:48:36 +0000 (+0100) Subject: Merge branch 'master' of git://bzr.sv.gnu.org/emacs/elpa X-Git-Url: https://code.delx.au/gnu-emacs-elpa/commitdiff_plain/ef4a54202c2a4ba734871ee524b406cc49962e7f?hp=e053cefa0cde7446c73cd1947a3a18c76b568073 Merge branch 'master' of git://bzr.sv.gnu.org/emacs/elpa --- diff --git a/externals-list b/externals-list index d024f974e..b7ec8806d 100644 --- a/externals-list +++ b/externals-list @@ -32,6 +32,7 @@ (("ack" :subtree "https://github.com/leoliu/ack-el") ("aggressive-indent" :subtree "https://github.com/Malabarba/aggressive-indent-mode") + ("async" :subtree "https://github.com/jwiegley/emacs-async") ("auctex" :external "git://git.sv.gnu.org/auctex.git") ("bug-hunter" :subtree "https://github.com/Malabarba/elisp-bug-hunter") ;;FIXME:("cedet" :external "??") diff --git a/packages/async/README.md b/packages/async/README.md new file mode 100644 index 000000000..a5b086651 --- /dev/null +++ b/packages/async/README.md @@ -0,0 +1,145 @@ +

License GPL 3 +MELPA +MELPA Stable

+ + +# emacs-async + +`async.el` is a module for doing asynchronous processing in Emacs. + +# Install + +## Install dired-async + +Add to your `.emacs.el`: + + (autoload 'dired-async-mode "dired-async.el" nil t) + (dired-async-mode 1) + +This will allow you to run asynchronously +the dired commands for copying, renaming and symlinking. +If you are a [helm](https://github.com/emacs-helm/helm) user, this will allow you +to copy, rename etc... asynchronously from [helm](https://github.com/emacs-helm/helm). +Note that with [helm](https://github.com/emacs-helm/helm) +you can disable this by running the copy, rename etc... commands with a prefix argument. + +If you don't want to make dired/helm asynchronous disable it with `dired-async-mode`. + +## Enable asynchronous compilation of your (M)elpa packages + +By default emacs package.el compile packages in its running emacs session. +This is not a problem when installing a new package (which is not actually loaded in current emacs) +but it may create errors and bad compilation when upgrading a package (old version of package is already loaded +and running in current emacs). +You can remedy to this by allowing async to compile your packages asynchronously, +(helm and magit actually do this by default, +so if you are using these packages they will compile asynchronously) +to do this, add to your init file: + + (async-bytecomp-package-mode 1) + + +You can control which packages will compile async with `async-bytecomp-allowed-packages`. +Set it to `'(all)` to be sure you will compile all packages asynchronously. + +# Usage + +The interface is intended to be very easy to use: + +## async-start + + async-start START-FUNC FINISH-FUNC + +Execute START-FUNC (often a lambda) in a subordinate Emacs process. When +done, the return value is passed to FINISH-FUNC. Example: + + (async-start + ;; What to do in the child process + (lambda () + (message "This is a test") + (sleep-for 3) + 222) + + ;; What to do when it finishes + (lambda (result) + (message "Async process done, result should be 222: %s" result))) + +If FINISH-FUNC is `nil` or missing, a future is returned that can be inspected +using `async-get`, blocking until the value is ready. Example: + + (let ((proc (async-start + ;; What to do in the child process + (lambda () + (message "This is a test") + (sleep-for 3) + 222)))) + + (message "I'm going to do some work here") ;; .... + + (message "Waiting on async process, result should be 222: %s" + (async-get proc))) + +If you don't want to use a callback, and you don't care about any return value +from the child process, pass the `'ignore` symbol as the second argument (if +you don't, and never call `async-get`, it will leave ``*emacs*`` process buffers +hanging around): + + (async-start + (lambda () + (delete-file "a remote file on a slow link" nil)) + 'ignore) + +Note: Even when FINISH-FUNC is present, a future is still returned except that +it yields no value (since the value is passed to FINISH-FUNC). Calling +`async-get` on such a future always returns `nil`. It can still be useful, +however, as an argument to `async-ready` or `async-wait`. + +## async-start-process + + async-start-process NAME PROGRAM FINISH-FUNC &rest PROGRAM-ARGS + +Start the executable PROGRAM asynchronously. See `async-start`. PROGRAM is +passed PROGRAM-ARGS, calling FINISH-FUNC with the process object when done. +If FINISH-FUNC is `nil`, the future object will return the process object when +the program is finished. Set DEFAULT-DIRECTORY to change PROGRAM's current +working directory. + +## async-get + + async-get FUTURE + +Get the value from an asynchronously called function when it is ready. FUTURE is +returned by `async-start` or `async-start-process` when its FINISH-FUNC is +`nil`. + +## async-ready + + async-ready FUTURE + +Query a FUTURE to see if its function's value is ready -- i.e., if no blocking +would result from a call to `async-get` on that FUTURE. + +## async-wait + + async-wait FUTURE + +Wait for FUTURE to become ready. + +## async-inject-variables + + async-inject-variables INCLUDE-REGEXP &optional PREDICATE EXCLUDE-REGEXP + +Return a `setq` form that replicates part of the calling environment. It sets +the value for every variable matching INCLUDE-REGEXP and also PREDICATE. It +will not perform injection for any variable matching EXCLUDE-REGEXP (if +present). It is intended to be used as follows: + + (async-start + `(lambda () + (require 'smtpmail) + (with-temp-buffer + (insert ,(buffer-substring-no-properties (point-min) (point-max))) + ;; Pass in the variable environment for smtpmail + ,(async-inject-variables "\\`\\(smtpmail\\|\\(user-\\)?mail\\)-") + (smtpmail-send-it))) + 'ignore) diff --git a/packages/async/async-bytecomp.el b/packages/async/async-bytecomp.el new file mode 100644 index 000000000..53d288da7 --- /dev/null +++ b/packages/async/async-bytecomp.el @@ -0,0 +1,172 @@ +;;; async-bytecomp.el --- Async functions to compile elisp files async + +;; Copyright (C) 2014 John Wiegley +;; Copyright (C) 2014 Thierry Volpiatto + +;; Authors: John Wiegley +;; Thierry Volpiatto + +;; Keywords: dired async byte-compile +;; 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: +;; +;; This package provide the `async-byte-recompile-directory' function +;; which allows, as the name says to recompile a directory outside of +;; your running emacs. +;; The benefit is your files will be compiled in a clean environment without +;; the old *.el files loaded. +;; Among other things, this fix a bug in package.el which recompile +;; the new files in the current environment with the old files loaded, creating +;; errors in most packages after upgrades. +;; +;; NB: This package is advicing the function `package--compile'. + +;;; Code: + +(require 'cl-lib) +(require 'async) + +(defcustom async-bytecomp-allowed-packages + '(async helm helm-core helm-ls-git helm-ls-hg magit) + "Packages in this list will be compiled asynchronously by `package--compile'. +All the dependencies of these packages will be compiled async too, +so no need to add dependencies to this list. +The value of this variable can also be a list with a single element, +the symbol `all', in this case packages are always compiled asynchronously." + :group 'async + :type '(repeat (choice symbol))) + +(defvar async-byte-compile-log-file "~/.emacs.d/async-bytecomp.log") + +;;;###autoload +(defun async-byte-recompile-directory (directory &optional quiet) + "Compile all *.el files in DIRECTORY asynchronously. +All *.elc files are systematically deleted before proceeding." + (cl-loop with dir = (directory-files directory t "\\.elc\\'") + unless dir return nil + for f in dir + when (file-exists-p f) do (delete-file f)) + ;; Ensure async is reloaded when async.elc is deleted. + ;; This happen when recompiling its own directory. + (load "async") + (let ((call-back + `(lambda (&optional ignore) + (if (file-exists-p async-byte-compile-log-file) + (let ((buf (get-buffer-create byte-compile-log-buffer)) + (n 0)) + (with-current-buffer buf + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert-file-contents async-byte-compile-log-file) + (compilation-mode)) + (display-buffer buf) + (delete-file async-byte-compile-log-file) + (unless ,quiet + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^.*:Error:" nil t) + (cl-incf n))) + (if (> n 0) + (message "Failed to compile %d files in directory `%s'" n ,directory) + (message "Directory `%s' compiled asynchronously with warnings" ,directory))))) + (unless ,quiet + (message "Directory `%s' compiled asynchronously with success" ,directory)))))) + (async-start + `(lambda () + (require 'bytecomp) + ,(async-inject-variables "\\`\\(load-path\\)\\|byte\\'") + (let ((default-directory (file-name-as-directory ,directory)) + error-data) + (add-to-list 'load-path default-directory) + (byte-recompile-directory ,directory 0 t) + (when (get-buffer byte-compile-log-buffer) + (setq error-data (with-current-buffer byte-compile-log-buffer + (buffer-substring-no-properties (point-min) (point-max)))) + (unless (string= error-data "") + (with-temp-file ,async-byte-compile-log-file + (erase-buffer) + (insert error-data)))))) + call-back) + (unless quiet (message "Started compiling asynchronously directory %s" directory)))) + +(defvar package-archive-contents) +(declare-function package-desc-reqs "package.el" (cl-x)) + +(defun async-bytecomp--get-package-deps (pkg &optional only) + ;; Same as `package--get-deps' but parse instead `package-archive-contents' + ;; because PKG is not already installed and not present in `package-alist'. + (let* ((pkg-desc (cadr (assq pkg package-archive-contents))) + (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) + for name = (car p) + when (assq name package-archive-contents) + collect name)) + (indirect-deps (unless (eq only 'direct) + (delete-dups + (cl-loop for p in direct-deps append + (async-bytecomp--get-package-deps p)))))) + (cl-case only + (direct direct-deps) + (separate (list direct-deps indirect-deps)) + (indirect indirect-deps) + (t (delete-dups (append direct-deps indirect-deps)))))) + +(defun async-bytecomp-get-allowed-pkgs () + (when (and async-bytecomp-allowed-packages + (listp async-bytecomp-allowed-packages)) + (if package-archive-contents + (cl-loop for p in async-bytecomp-allowed-packages + when (assq p package-archive-contents) + append (async-bytecomp--get-package-deps p) into reqs + finally return + (delete-dups + (append async-bytecomp-allowed-packages reqs))) + async-bytecomp-allowed-packages))) + +(defadvice package--compile (around byte-compile-async) + (let ((cur-package (package-desc-name pkg-desc)) + (pkg-dir (package-desc-dir pkg-desc))) + (if (or (equal async-bytecomp-allowed-packages '(all)) + (memq cur-package (async-bytecomp-get-allowed-pkgs))) + (progn + (when (eq cur-package 'async) + (fmakunbound 'async-byte-recompile-directory)) + ;; Add to `load-path' the latest version of async and + ;; reload it when reinstalling async. + (when (string= cur-package "async") + (cl-pushnew pkg-dir load-path) + (load "async-bytecomp")) + ;; `async-byte-recompile-directory' will add directory + ;; as needed to `load-path'. + (async-byte-recompile-directory (package-desc-dir pkg-desc) t)) + ad-do-it))) + +;;;###autoload +(define-minor-mode async-bytecomp-package-mode + "Byte compile asynchronously packages installed with package.el. +Async compilation of packages can be controlled by +`async-bytecomp-allowed-packages'." + :group 'async + :global t + (if async-bytecomp-package-mode + (ad-activate 'package--compile) + (ad-deactivate 'package--compile))) + +(provide 'async-bytecomp) + +;;; async-bytecomp.el ends here diff --git a/packages/async/async-pkg.el b/packages/async/async-pkg.el new file mode 100644 index 000000000..0268724c7 --- /dev/null +++ b/packages/async/async-pkg.el @@ -0,0 +1,12 @@ +;;; async-pkg.el + +(define-package "async" "1.6" + "Asynchronous processing in Emacs" + '((emacs "24") + (cl-lib "0.5")) + :url "https://github.com/jwiegley/emacs-async") + +;; Local Variables: +;; no-byte-compile: t +;; End: + diff --git a/packages/async/async-test.el b/packages/async/async-test.el new file mode 100644 index 000000000..e37e33d5b --- /dev/null +++ b/packages/async/async-test.el @@ -0,0 +1,140 @@ +;;; async-test.el --- async.el-related tests + +;; Copyright (C) 2012~2014 John Wiegley + +;; Author: John Wiegley +;; Created: 10 Jul 2012 +;; Version: 1.0 +;; Keywords: async +;; X-URL: https://github.com/jwiegley/emacs-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: + +;; Contains tests for all the async modules. + +;;; Code: + +(require 'async) + + +(eval-when-compile + (require 'cl)) + +(defun async-test-1 () + (interactive) + (message "Starting async-test-1...") + (async-start + ;; What to do in the child process + (lambda () + (message "This is a test") + (sleep-for 3) + 222) + + ;; What to do when it finishes + (lambda (result) + (message "Async process done, result should be 222: %s" result))) + (message "Starting async-test-1...done")) + +(defun async-test-2 () + (interactive) + (message "Starting async-test-2...") + (let ((proc (async-start + ;; What to do in the child process + (lambda () + (message "This is a test") + (sleep-for 3) + 222)))) + (message "I'm going to do some work here") + ;; .... + (message "Async process done, result should be 222: %s" + (async-get proc)))) + +(defun async-test-3 () + (interactive) + (message "Starting async-test-3...") + (async-start + ;; What to do in the child process + (lambda () + (message "This is a test") + (sleep-for 3) + (error "Error in child process") + 222) + + ;; What to do when it finishes + (lambda (result) + (message "Async process done, result should be 222: %s" result))) + (message "Starting async-test-1...done")) + +(defun async-test-4 () + (interactive) + (message "Starting async-test-4...") + (async-start-process "sleep" "sleep" + ;; What to do when it finishes + (lambda (proc) + (message "Sleep done, exit code was %d" + (process-exit-status proc))) + "3") + (message "Starting async-test-4...done")) + +(defun async-test-5 () + (interactive) + (message "Starting async-test-5...") + (let ((proc + (async-start + ;; What to do in the child process + (lambda () + (message "This is a test, sending message") + (async-send :hello "world") + ;; wait for a message + (let ((msg (async-receive))) + (message "Child got message: %s" + (plist-get msg :goodbye))) + (sleep-for 3) + 222) + + ;; What to do when it finishes + (lambda (result) + (if (async-message-p result) + (message "Got hello from child process: %s" + (plist-get result :hello)) + (message "Async process done, result should be 222: %s" + result)))))) + (async-send proc :goodbye "everyone")) + (message "Starting async-test-5...done")) + +(defun async-test-6 () + (interactive) + (message "Starting async-test-6...") + (async-start + ;; What to do in the child process + `(lambda () + ,(async-inject-variables "\\`user-mail-address\\'") + (format "user-mail-address = %s" user-mail-address)) + + ;; What to do when it finishes + (lambda (result) + (message "Async process done: %s" result)))) + + +(provide 'async-test) + +;;; async-test.el ends here + +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/packages/async/async.el b/packages/async/async.el new file mode 100644 index 000000000..2f579324a --- /dev/null +++ b/packages/async/async.el @@ -0,0 +1,292 @@ +;;; async.el --- Asynchronous processing in Emacs + +;; Copyright (C) 2012~2014 John Wiegley + +;; Author: John Wiegley +;; Created: 18 Jun 2012 + +;; Keywords: async +;; X-URL: https://github.com/jwiegley/emacs-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: + +;; Adds the ability to call asynchronous functions and process with ease. See +;; the documentation for `async-start' and `async-start-process'. + +;;; Code: + +(defgroup async nil + "Simple asynchronous processing in Emacs" + :group 'emacs) + +(defvar async-debug nil) +(defvar async-send-over-pipe t) +(defvar async-in-child-emacs nil) +(defvar async-callback nil) +(defvar async-callback-for-process nil) +(defvar async-callback-value nil) +(defvar async-callback-value-set nil) +(defvar async-current-process nil) +(defvar async--procvar nil) + +(defun async-inject-variables + (include-regexp &optional predicate exclude-regexp) + "Return a `setq' form that replicates part of the calling environment. +It sets the value for every variable matching INCLUDE-REGEXP and +also PREDICATE. It will not perform injection for any variable +matching EXCLUDE-REGEXP (if present). It is intended to be used +as follows: + + (async-start + `(lambda () + (require 'smtpmail) + (with-temp-buffer + (insert ,(buffer-substring-no-properties (point-min) (point-max))) + ;; Pass in the variable environment for smtpmail + ,(async-inject-variables \"\\`\\(smtpmail\\|\\(user-\\)?mail\\)-\") + (smtpmail-send-it))) + 'ignore)" + `(setq + ,@(let (bindings) + (mapatoms + (lambda (sym) + (if (and (boundp sym) + (or (null include-regexp) + (string-match include-regexp (symbol-name sym))) + (not (string-match + (or exclude-regexp "-syntax-table\\'") + (symbol-name sym)))) + (let ((value (symbol-value sym))) + (when (or (null predicate) + (funcall predicate sym)) + (setq bindings (cons `(quote ,value) bindings) + bindings (cons sym bindings))))))) + bindings))) + +(defalias 'async-inject-environment 'async-inject-variables) + +(defun async-handle-result (func result buf) + (if (null func) + (progn + (set (make-local-variable 'async-callback-value) result) + (set (make-local-variable 'async-callback-value-set) t)) + (unwind-protect + (if (and (listp result) + (eq 'async-signal (nth 0 result))) + (signal (car (nth 1 result)) + (cdr (nth 1 result))) + (funcall func result)) + (unless async-debug + (kill-buffer buf))))) + +(defun async-when-done (proc &optional change) + "Process sentinal used to retrieve the value from the child process." + (when (eq 'exit (process-status proc)) + (with-current-buffer (process-buffer proc) + (let ((async-current-process proc)) + (if (= 0 (process-exit-status proc)) + (if async-callback-for-process + (if async-callback + (prog1 + (funcall async-callback proc) + (unless async-debug + (kill-buffer (current-buffer)))) + (set (make-local-variable 'async-callback-value) proc) + (set (make-local-variable 'async-callback-value-set) t)) + (goto-char (point-max)) + (backward-sexp) + (async-handle-result async-callback (read (current-buffer)) + (current-buffer))) + (set (make-local-variable 'async-callback-value) + (list 'error + (format "Async process '%s' failed with exit code %d" + (process-name proc) (process-exit-status proc)))) + (set (make-local-variable 'async-callback-value-set) t)))))) + +(defun async--receive-sexp (&optional stream) + (let ((sexp (decode-coding-string (base64-decode-string + (read stream)) 'utf-8-unix))) + (if async-debug + (message "Received sexp {{{%s}}}" (pp-to-string sexp))) + (setq sexp (read sexp)) + (if async-debug + (message "Read sexp {{{%s}}}" (pp-to-string sexp))) + (eval sexp))) + +(defun async--insert-sexp (sexp) + (let (print-level print-length) + (prin1 sexp (current-buffer)) + ;; Just in case the string we're sending might contain EOF + (encode-coding-region (point-min) (point-max) 'utf-8-unix) + (base64-encode-region (point-min) (point-max) t) + (goto-char (point-min)) (insert ?\") + (goto-char (point-max)) (insert ?\" ?\n))) + +(defun async--transmit-sexp (process sexp) + (with-temp-buffer + (if async-debug + (message "Transmitting sexp {{{%s}}}" (pp-to-string sexp))) + (async--insert-sexp sexp) + (process-send-region process (point-min) (point-max)))) + +(defun async-batch-invoke () + "Called from the child Emacs process' command-line." + (setq async-in-child-emacs t + debug-on-error async-debug) + (if debug-on-error + (prin1 (funcall + (async--receive-sexp (unless async-send-over-pipe + command-line-args-left)))) + (condition-case err + (prin1 (funcall + (async--receive-sexp (unless async-send-over-pipe + command-line-args-left)))) + (error + (prin1 (list 'async-signal err)))))) + +(defun async-ready (future) + "Query a FUTURE to see if the ready is ready -- i.e., if no blocking +would result from a call to `async-get' on that FUTURE." + (and (memq (process-status future) '(exit signal)) + (with-current-buffer (process-buffer future) + async-callback-value-set))) + +(defun async-wait (future) + "Wait for FUTURE to become ready." + (while (not (async-ready future)) + (sit-for 0.05))) + +(defun async-get (future) + "Get the value from an asynchronously function when it is ready. +FUTURE is returned by `async-start' or `async-start-process' when +its FINISH-FUNC is nil." + (async-wait future) + (with-current-buffer (process-buffer future) + (async-handle-result #'identity async-callback-value (current-buffer)))) + +(defun async-message-p (value) + "Return true of VALUE is an async.el message packet." + (and (listp value) + (plist-get value :async-message))) + +(defun async-send (&rest args) + "Send the given messages to the asychronous Emacs PROCESS." + (let ((args (append args '(:async-message t)))) + (if async-in-child-emacs + (if async-callback + (funcall async-callback args)) + (async--transmit-sexp (car args) (list 'quote (cdr args)))))) + +(defun async-receive (&rest args) + "Send the given messages to the asychronous Emacs PROCESS." + (async--receive-sexp)) + +;;;###autoload +(defun async-start-process (name program finish-func &rest program-args) + "Start the executable PROGRAM asynchronously. See `async-start'. +PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the +process object when done. If FINISH-FUNC is nil, the future +object will return the process object when the program is +finished. Set DEFAULT-DIRECTORY to change PROGRAM's current +working directory." + (let* ((buf (generate-new-buffer (concat "*" name "*"))) + (proc (let ((process-connection-type nil)) + (apply #'start-process name buf program program-args)))) + (with-current-buffer buf + (set (make-local-variable 'async-callback) finish-func) + (set-process-sentinel proc #'async-when-done) + (unless (string= name "emacs") + (set (make-local-variable 'async-callback-for-process) t)) + proc))) + +;;;###autoload +(defun async-start (start-func &optional finish-func) + "Execute START-FUNC (often a lambda) in a subordinate Emacs process. +When done, the return value is passed to FINISH-FUNC. Example: + + (async-start + ;; What to do in the child process + (lambda () + (message \"This is a test\") + (sleep-for 3) + 222) + + ;; What to do when it finishes + (lambda (result) + (message \"Async process done, result should be 222: %s\" + result))) + +If FINISH-FUNC is nil or missing, a future is returned that can +be inspected using `async-get', blocking until the value is +ready. Example: + + (let ((proc (async-start + ;; What to do in the child process + (lambda () + (message \"This is a test\") + (sleep-for 3) + 222)))) + + (message \"I'm going to do some work here\") ;; .... + + (message \"Waiting on async process, result should be 222: %s\" + (async-get proc))) + +If you don't want to use a callback, and you don't care about any +return value form the child process, pass the `ignore' symbol as +the second argument (if you don't, and never call `async-get', it +will leave *emacs* process buffers hanging around): + + (async-start + (lambda () + (delete-file \"a remote file on a slow link\" nil)) + 'ignore) + +Note: Even when FINISH-FUNC is present, a future is still +returned except that it yields no value (since the value is +passed to FINISH-FUNC). Call `async-get' on such a future always +returns nil. It can still be useful, however, as an argument to +`async-ready' or `async-wait'." + (let ((sexp start-func)) + (setq async--procvar + (async-start-process + "emacs" (file-truename + (expand-file-name invocation-name + invocation-directory)) + finish-func + "-Q" "-l" + ;; Using `locate-library' ensure we use the right file + ;; when the .elc have been deleted. + (locate-library "async") + "-batch" "-f" "async-batch-invoke" + (if async-send-over-pipe + "" + (with-temp-buffer + (async--insert-sexp (list 'quote sexp)) + (buffer-string))))) + (if async-send-over-pipe + (async--transmit-sexp async--procvar (list 'quote sexp))) + async--procvar)) + +(defmacro async-sandbox(func) + "Evaluate FUNC in a separate Emacs process, synchronously." + `(async-get (async-start ,func))) + +(provide 'async) + +;;; async.el ends here diff --git a/packages/async/dired-async.el b/packages/async/dired-async.el new file mode 100644 index 000000000..3f5349dad --- /dev/null +++ b/packages/async/dired-async.el @@ -0,0 +1,291 @@ +;;; dired-async.el --- Copy/move/delete asynchronously in dired. + +;; Copyright (C) 2012~2014 John Wiegley +;; Copyright (C) 2012~2014 Thierry Volpiatto + +;; Authors: John Wiegley +;; Thierry Volpiatto + +;; 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: + +;; This file provide a redefinition of `dired-create-file' function, +;; 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: + +;; (dired-async-mode 1) + +;; This will enable async copy/rename etc... +;; in dired and helm. + +;;; Code: + +(require 'cl-lib) +(require 'dired-aux) +(require 'async) + +(eval-when-compile + (defvar async-callback)) +(defvar dired-async-operation nil) + +(defgroup dired-async nil + "Copy rename files asynchronously from dired." + :group 'dired) + +(defcustom dired-async-env-variables-regexp + "\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*" + "Variables matching this regexp will be loaded on Child Emacs." + :type 'regexp + :group 'dired-async) + +(defcustom dired-async-message-function 'dired-async-mode-line-message + "Function to use to notify result when operation finish. +Should take same args as `message'." + :group 'dired-async + :type 'function) + +(defcustom dired-async-log-file "/tmp/dired-async.log" + "File use to communicate errors from Child Emacs to host Emacs." + :group 'dired-async + :type 'string) + +(defface dired-async-message + '((t (:foreground "yellow"))) + "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." + :group 'dired-async) + +(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 + (let ((visible-bell t)) (ding)))) + +(defun dired-async-mode-line-message (text &rest args) + "Notify end of operation in `mode-line'." + (message nil) + (let ((mode-line-format (concat + " " (propertize + (if args + (apply #'format text args) + text) + 'face 'dired-async-message)))) + (force-mode-line-update) + (sit-for 3) + (force-mode-line-update))) + +(defun dired-async-processes () + (cl-loop for p in (process-list) + when (cl-loop for c in (process-command p) thereis + (string= "async-batch-invoke" c)) + collect p)) + +(defun dired-async-kill-process () + (interactive) + (let* ((processes (dired-async-processes)) + (proc (car (last processes)))) + (delete-process proc) + (unless (> (length processes) 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)) + (when dired-async-operation + (if (file-exists-p dired-async-log-file) + (progn + (pop-to-buffer (get-buffer-create "*dired async*")) + (erase-buffer) + (insert "Error: ") + (insert-file-contents dired-async-log-file) + (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)))) + +(defun dired-async-maybe-kill-ftp () + "Return a form to kill ftp process in child emacs." + (quote + (progn + (require 'cl-lib) + (let ((buf (cl-loop for b in (buffer-list) + thereis (and (string-match + "\\`\\*ftp.*" + (buffer-name b)) b)))) + (when buf (kill-buffer buf)))))) + +(defun dired-async-create-files (file-creator operation fn-list name-constructor + &optional marker-char) + "Same as `dired-create-files' but asynchronous. + +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) + (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))) + (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))))) + (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 + (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)))) + ;; Start async process. + (when async-fn-list + (async-start `(lambda () + (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))) + (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) + (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 '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) + +;;; dired-async.el ends here diff --git a/packages/async/smtpmail-async.el b/packages/async/smtpmail-async.el new file mode 100644 index 000000000..99c4017b0 --- /dev/null +++ b/packages/async/smtpmail-async.el @@ -0,0 +1,73 @@ +;;; smtpmail-async.el --- Send e-mail with smtpmail.el asynchronously + +;; Copyright (C) 2012~2014 John Wiegley + +;; Author: John Wiegley +;; Created: 18 Jun 2012 + +;; Keywords: email async +;; X-URL: https://github.com/jwiegley/emacs-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: + +;; Send e-mail with smtpmail.el asynchronously. To use: +;; +;; (require 'smtpmail-async) +;; +;; (setq send-mail-function 'async-smtpmail-send-it +;; message-send-mail-function 'async-smtpmail-send-it) +;; +;; This assumes you already have smtpmail.el working. + +;;; Code: + +(defgroup smtpmail-async nil + "Send e-mail with smtpmail.el asynchronously" + :group 'smptmail) + +(require 'async) +(require 'smtpmail) +(require 'message) + +(defvar async-smtpmail-before-send-hook nil + "Hook running in the child emacs in `async-smtpmail-send-it'. +It is called just before calling `smtpmail-send-it'.") + +(defun async-smtpmail-send-it () + (let ((to (message-field-value "To")) + (buf-content (buffer-substring-no-properties + (point-min) (point-max)))) + (message "Delivering message to %s..." to) + (async-start + `(lambda () + (require 'smtpmail) + (with-temp-buffer + (insert ,buf-content) + (set-buffer-multibyte nil) + ;; Pass in the variable environment for smtpmail + ,(async-inject-variables + "\\`\\(smtpmail\\|async-smtpmail\\|\\(user-\\)?mail\\)-\\|auth-sources\\|epg" + nil "\\`\\(mail-header-format-function\\|smtpmail-address-buffer\\|mail-mode-abbrev-table\\)") + (run-hooks 'async-smtpmail-before-send-hook) + (smtpmail-send-it))) + `(lambda (&optional ignore) + (message "Delivering message to %s...done" ,to))))) + +(provide 'smtpmail-async) + +;;; smtpmail-async.el ends here