X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/3d388c66816450ddd2afad520cf1f7bf9b1f3c74..228ec4bb351a9e14e338b9cb09eeb4809957c909:/async.el diff --git a/async.el b/async.el index 6b9dab29a..dc732707b 100644 --- a/async.el +++ b/async.el @@ -1,12 +1,13 @@ -;;; async --- Asynchronous processing in Emacs +;;; async.el --- Asynchronous processing in Emacs -*- lexical-binding: t -*- -;; Copyright (C) 2012 John Wiegley +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; Author: John Wiegley ;; Created: 18 Jun 2012 -;; Version: 1.0 +;; Version: 1.6 + ;; Keywords: async -;; X-URL: https://github.com/jwiegley/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 @@ -25,42 +26,8 @@ ;;; Commentary: -;; Adds the ability to process Lisp concurrently, with a very simple syntax: -;; -;; (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 you omit the callback function, `async-start' will return a process -;; object that you can call `async-get' on when you're ready to wait for the -;; result value: -;; -;; (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))) -;; -;; If you don't want to use a callback, and you don't care about any return -;; value form the child proces, pass the `ignore' symbol as the second -;; argument: -;; -;; (async-start -;; (lambda () -;; (delete-file "a remote file on a slow link" nil)) -;; 'ignore) +;; Adds the ability to call asynchronous functions and process with ease. See +;; the documentation for `async-start' and `async-start-process'. ;;; Code: @@ -68,126 +35,268 @@ "Simple asynchronous processing in Emacs" :group 'emacs) -(defvar async-callback) +(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-when-done (proc &optional change) - "Process sentinal used to retrieve the value from the child process." +(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 sentinel used to retrieve the value from the child process." (when (eq 'exit (process-status proc)) (with-current-buffer (process-buffer proc) - (if (= 0 (process-exit-status proc)) - (progn - (goto-char (point-max)) - (backward-sexp) - (let ((result (read (current-buffer)))) - (if (and (listp result) - (eq 'async-signal (car result))) - (if (eq 'error (car (cdr result))) - (error (cadr (cdr result))) - (apply #'signal (cdr result))) + (let ((async-current-process proc)) + (if (= 0 (process-exit-status proc)) + (if async-callback-for-process (if async-callback (prog1 - (funcall async-callback result) - (kill-buffer (current-buffer))) - (set (make-local-variable 'async-callback-value) result) - (set (make-local-variable 'async-callback-value-set) t))))) - (set (make-local-variable 'async-callback-value) 'error) - (set (make-local-variable 'async-callback-value-set) t) - (error "Async Emacs process failed with exit code %d" - (process-exit-status proc)))))) + (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)) + ;; Parent expects UTF-8 encoded text. + (coding-system-for-write '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 + (print-escape-nonascii t) + (print-circle t)) + (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." - (condition-case err - (prin1 (funcall (eval (read (nth 5 command-line-args))))) - (signal - (prin1 `(async-signal . ,err))) - (error - (prin1 `(async-signal . ,err))))) - -(defun async-get (proc) - "Wait until PROC has successfully completed." - (with-current-buffer (process-buffer proc) - (while (and (not (eq 'exit (process-status proc))) - (not async-callback-value-set)) - (sit-for 0 50)) - (prog1 - async-callback-value - (kill-buffer (current-buffer))))) - -(defmacro async-start (start-func &optional finish-func) - "Fork execution of `start-func' into its own Emacs process. -`start-func' must be a `read'-able symbol or lambda form. It -cannot be a byte-compiled lambda. - -`finish-func' is called with the result of `start-func' when that -process has completed. If it is nil, `async-start' will return a -process object that you can block on with `async-future-get' in -order to wait for the result of `start-func'. This would allow -you to start some expensive background processing at the -beginning of a command, then wait for the result only when you're -ready to use it." - (let ((bufvar (make-symbol "buf")) - (procvar (make-symbol "proc"))) - (require 'find-func) - `(let* ((,bufvar (generate-new-buffer "*emacs*")) - (,procvar - (start-process "emacs" ,bufvar - (expand-file-name invocation-name - invocation-directory) - "-Q" "-l" (find-library-name "async") - "-batch" "-f" "async-batch-invoke" - (prin1-to-string (list 'quote ,start-func))))) - (with-current-buffer ,bufvar - (set (make-local-variable 'async-callback) ,finish-func) - (set-process-sentinel ,procvar #'async-when-done) - ,procvar)))) - -(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")) + ;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent + ;; process expects. + (let ((coding-system-for-write 'utf-8-unix)) + (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 () + "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 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). 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) + ;; Subordinate Emacs will send text encoded in UTF-8. + (coding-system-for-read 'utf-8-unix)) + (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)