code.delx.au - gnu-emacs-elpa/blob - packages/async/async.el

   1 ;;; async.el --- Asynchronous processing in Emacs
   2
   3 ;; Copyright (C) 2012~2014 John Wiegley
   4
   5 ;; Author: John Wiegley <jwiegley@gmail.com>
   6 ;; Created: 18 Jun 2012
   7
   8 ;; Keywords: async
   9 ;; X-URL: https://github.com/jwiegley/emacs-async
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 \f
  26 ;;; Commentary:
  27
  28 ;; Adds the ability to call asynchronous functions and process with ease.  See
  29 ;; the documentation for `async-start' and `async-start-process'.
  30 \f
  31 ;;; Code:
  32
  33 (defgroup async nil
  34   "Simple asynchronous processing in Emacs"
  35   :group 'emacs)
  36
  37 (defvar async-debug nil)
  38 (defvar async-send-over-pipe t)
  39 (defvar async-in-child-emacs nil)
  40 (defvar async-callback nil)
  41 (defvar async-callback-for-process nil)
  42 (defvar async-callback-value nil)
  43 (defvar async-callback-value-set nil)
  44 (defvar async-current-process nil)
  45 (defvar async--procvar nil)
  46
  47 (defun async-inject-variables
  48   (include-regexp &optional predicate exclude-regexp)
  49   "Return a `setq' form that replicates part of the calling environment.
  50 It sets the value for every variable matching INCLUDE-REGEXP and
  51 also PREDICATE.  It will not perform injection for any variable
  52 matching EXCLUDE-REGEXP (if present).  It is intended to be used
  53 as follows:
  54
  55     (async-start
  56        `(lambda ()
  57           (require 'smtpmail)
  58           (with-temp-buffer
  59             (insert ,(buffer-substring-no-properties (point-min) (point-max)))
  60             ;; Pass in the variable environment for smtpmail
  61             ,(async-inject-variables \"\\`\\(smtpmail\\|\\(user-\\)?mail\\)-\")
  62             (smtpmail-send-it)))
  63        'ignore)"
  64   `(setq
  65     ,@(let (bindings)
  66         (mapatoms
  67          (lambda (sym)
  68            (if (and (boundp sym)
  69                     (or (null include-regexp)
  70                         (string-match include-regexp (symbol-name sym)))
  71                     (not (string-match
  72                           (or exclude-regexp "-syntax-table\\'")
  73                           (symbol-name sym))))
  74                (let ((value (symbol-value sym)))
  75                  (when (or (null predicate)
  76                            (funcall predicate sym))
  77                    (setq bindings (cons `(quote ,value) bindings)
  78                          bindings (cons sym bindings)))))))
  79         bindings)))
  80
  81 (defalias 'async-inject-environment 'async-inject-variables)
  82
  83 (defun async-handle-result (func result buf)
  84   (if (null func)
  85       (progn
  86         (set (make-local-variable 'async-callback-value) result)
  87         (set (make-local-variable 'async-callback-value-set) t))
  88     (unwind-protect
  89         (if (and (listp result)
  90                  (eq 'async-signal (nth 0 result)))
  91             (signal (car (nth 1 result))
  92                     (cdr (nth 1 result)))
  93           (funcall func result))
  94       (unless async-debug
  95         (kill-buffer buf)))))
  96
  97 (defun async-when-done (proc &optional change)
  98   "Process sentinal used to retrieve the value from the child process."
  99   (when (eq 'exit (process-status proc))
 100     (with-current-buffer (process-buffer proc)
 101       (let ((async-current-process proc))
 102         (if (= 0 (process-exit-status proc))
 103             (if async-callback-for-process
 104                 (if async-callback
 105                     (prog1
 106                         (funcall async-callback proc)
 107                       (unless async-debug
 108                         (kill-buffer (current-buffer))))
 109                   (set (make-local-variable 'async-callback-value) proc)
 110                   (set (make-local-variable 'async-callback-value-set) t))
 111               (goto-char (point-max))
 112               (backward-sexp)
 113               (async-handle-result async-callback (read (current-buffer))
 114                                    (current-buffer)))
 115           (set (make-local-variable 'async-callback-value)
 116                (list 'error
 117                      (format "Async process '%s' failed with exit code %d"
 118                              (process-name proc) (process-exit-status proc))))
 119           (set (make-local-variable 'async-callback-value-set) t))))))
 120
 121 (defun async--receive-sexp (&optional stream)
 122   (let ((sexp (decode-coding-string (base64-decode-string
 123                                      (read stream)) 'utf-8-unix)))
 124     (if async-debug
 125         (message "Received sexp {{{%s}}}" (pp-to-string sexp)))
 126     (setq sexp (read sexp))
 127     (if async-debug
 128         (message "Read sexp {{{%s}}}" (pp-to-string sexp)))
 129     (eval sexp)))
 130
 131 (defun async--insert-sexp (sexp)
 132   (let (print-level print-length)
 133     (prin1 sexp (current-buffer))
 134     ;; Just in case the string we're sending might contain EOF
 135     (encode-coding-region (point-min) (point-max) 'utf-8-unix)
 136     (base64-encode-region (point-min) (point-max) t)
 137     (goto-char (point-min)) (insert ?\")
 138     (goto-char (point-max)) (insert ?\" ?\n)))
 139
 140 (defun async--transmit-sexp (process sexp)
 141   (with-temp-buffer
 142     (if async-debug
 143         (message "Transmitting sexp {{{%s}}}" (pp-to-string sexp)))
 144     (async--insert-sexp sexp)
 145     (process-send-region process (point-min) (point-max))))
 146
 147 (defun async-batch-invoke ()
 148   "Called from the child Emacs process' command-line."
 149   (setq async-in-child-emacs t
 150         debug-on-error async-debug)
 151   (if debug-on-error
 152       (prin1 (funcall
 153               (async--receive-sexp (unless async-send-over-pipe
 154                                      command-line-args-left))))
 155     (condition-case err
 156         (prin1 (funcall
 157                 (async--receive-sexp (unless async-send-over-pipe
 158                                        command-line-args-left))))
 159       (error
 160        (prin1 (list 'async-signal err))))))
 161
 162 (defun async-ready (future)
 163   "Query a FUTURE to see if the ready is ready -- i.e., if no blocking
 164 would result from a call to `async-get' on that FUTURE."
 165   (and (memq (process-status future) '(exit signal))
 166        (with-current-buffer (process-buffer future)
 167          async-callback-value-set)))
 168
 169 (defun async-wait (future)
 170   "Wait for FUTURE to become ready."
 171   (while (not (async-ready future))
 172     (sit-for 0.05)))
 173
 174 (defun async-get (future)
 175   "Get the value from an asynchronously function when it is ready.
 176 FUTURE is returned by `async-start' or `async-start-process' when
 177 its FINISH-FUNC is nil."
 178   (async-wait future)
 179   (with-current-buffer (process-buffer future)
 180     (async-handle-result #'identity async-callback-value (current-buffer))))
 181
 182 (defun async-message-p (value)
 183   "Return true of VALUE is an async.el message packet."
 184   (and (listp value)
 185        (plist-get value :async-message)))
 186
 187 (defun async-send (&rest args)
 188   "Send the given messages to the asychronous Emacs PROCESS."
 189   (let ((args (append args '(:async-message t))))
 190     (if async-in-child-emacs
 191         (if async-callback
 192             (funcall async-callback args))
 193       (async--transmit-sexp (car args) (list 'quote (cdr args))))))
 194
 195 (defun async-receive (&rest args)
 196   "Send the given messages to the asychronous Emacs PROCESS."
 197   (async--receive-sexp))
 198
 199 ;;;###autoload
 200 (defun async-start-process (name program finish-func &rest program-args)
 201   "Start the executable PROGRAM asynchronously.  See `async-start'.
 202 PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
 203 process object when done.  If FINISH-FUNC is nil, the future
 204 object will return the process object when the program is
 205 finished.  Set DEFAULT-DIRECTORY to change PROGRAM's current
 206 working directory."
 207   (let* ((buf (generate-new-buffer (concat "*" name "*")))
 208          (proc (let ((process-connection-type nil))
 209                  (apply #'start-process name buf program program-args))))
 210     (with-current-buffer buf
 211       (set (make-local-variable 'async-callback) finish-func)
 212       (set-process-sentinel proc #'async-when-done)
 213       (unless (string= name "emacs")
 214         (set (make-local-variable 'async-callback-for-process) t))
 215       proc)))
 216
 217 ;;;###autoload
 218 (defun async-start (start-func &optional finish-func)
 219   "Execute START-FUNC (often a lambda) in a subordinate Emacs process.
 220 When done, the return value is passed to FINISH-FUNC.  Example:
 221
 222     (async-start
 223        ;; What to do in the child process
 224        (lambda ()
 225          (message \"This is a test\")
 226          (sleep-for 3)
 227          222)
 228
 229        ;; What to do when it finishes
 230        (lambda (result)
 231          (message \"Async process done, result should be 222: %s\"
 232                   result)))
 233
 234 If FINISH-FUNC is nil or missing, a future is returned that can
 235 be inspected using `async-get', blocking until the value is
 236 ready.  Example:
 237
 238     (let ((proc (async-start
 239                    ;; What to do in the child process
 240                    (lambda ()
 241                      (message \"This is a test\")
 242                      (sleep-for 3)
 243                      222))))
 244
 245         (message \"I'm going to do some work here\") ;; ....
 246
 247         (message \"Waiting on async process, result should be 222: %s\"
 248                  (async-get proc)))
 249
 250 If you don't want to use a callback, and you don't care about any
 251 return value form the child process, pass the `ignore' symbol as
 252 the second argument (if you don't, and never call `async-get', it
 253 will leave *emacs* process buffers hanging around):
 254
 255     (async-start
 256      (lambda ()
 257        (delete-file \"a remote file on a slow link\" nil))
 258      'ignore)
 259
 260 Note: Even when FINISH-FUNC is present, a future is still
 261 returned except that it yields no value (since the value is
 262 passed to FINISH-FUNC).  Call `async-get' on such a future always
 263 returns nil.  It can still be useful, however, as an argument to
 264 `async-ready' or `async-wait'."
 265   (let ((sexp start-func))
 266     (setq async--procvar
 267           (async-start-process
 268            "emacs" (file-truename
 269                     (expand-file-name invocation-name
 270                                       invocation-directory))
 271            finish-func
 272            "-Q" "-l"
 273            ;; Using `locate-library' ensure we use the right file
 274            ;; when the .elc have been deleted.
 275            (locate-library "async")
 276            "-batch" "-f" "async-batch-invoke"
 277            (if async-send-over-pipe
 278                "<none>"
 279                (with-temp-buffer
 280                  (async--insert-sexp (list 'quote sexp))
 281                  (buffer-string)))))
 282     (if async-send-over-pipe
 283         (async--transmit-sexp async--procvar (list 'quote sexp)))
 284     async--procvar))
 285
 286 (defmacro async-sandbox(func)
 287   "Evaluate FUNC in a separate Emacs process, synchronously."
 288   `(async-get (async-start ,func)))
 289
 290 (provide 'async)
 291
 292 ;;; async.el ends here