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

   1 ;;; async --- Asynchronous processing in Emacs
   2
   3 ;; Copyright (C) 2012~2013 John Wiegley
   4
   5 ;; Author: John Wiegley <jwiegley@gmail.com>
   6 ;; Created: 18 Jun 2012
   7 ;; Version: 1.1
   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
  46 (defun async-inject-variables
  47   (include-regexp &optional predicate exclude-regexp)
  48   "Return a `setq' form that replicates part of the calling environment.
  49 It sets the value for every variable matching INCLUDE-REGEXP and
  50 also PREDICATE.  It will not perform injection for any variable
  51 matching EXCLUDE-REGEXP (if present).  It is intended to be used
  52 as follows:
  53
  54     (async-start
  55        `(lambda ()
  56           (require 'smtpmail)
  57           (with-temp-buffer
  58             (insert ,(buffer-substring-no-properties (point-min) (point-max)))
  59             ;; Pass in the variable environment for smtpmail
  60             ,(async-inject-variables \"\\`\\(smtpmail\\|\\(user-\\)?mail\\)-\")
  61             (smtpmail-send-it)))
  62        'ignore)"
  63   `(setq
  64     ,@(let (bindings)
  65         (mapatoms
  66          (lambda (sym)
  67            (if (and (boundp sym)
  68                     (or (null include-regexp)
  69                         (string-match include-regexp (symbol-name sym)))
  70                     (not (string-match
  71                           (or exclude-regexp "-syntax-table\\'")
  72                           (symbol-name sym))))
  73                (let ((value (symbol-value sym)))
  74                  (when (or (null predicate)
  75                            (funcall predicate sym))
  76                    (setq bindings (cons `(quote ,value) bindings)
  77                          bindings (cons sym bindings)))))))
  78         bindings)))
  79
  80 (defalias 'async-inject-environment 'async-inject-variables)
  81
  82 (defun async-handle-result (func result buf)
  83   (if (null func)
  84       (progn
  85         (set (make-local-variable 'async-callback-value) result)
  86         (set (make-local-variable 'async-callback-value-set) t))
  87     (unwind-protect
  88         (if (and (listp result)
  89                  (eq 'async-signal (nth 0 result)))
  90             (signal (car (nth 1 result))
  91                     (cdr (nth 1 result)))
  92           (funcall func result))
  93       (unless async-debug
  94         (kill-buffer buf)))))
  95
  96 (defun async-when-done (proc &optional change)
  97   "Process sentinal used to retrieve the value from the child process."
  98   (when (eq 'exit (process-status proc))
  99     (with-current-buffer (process-buffer proc)
 100       (let ((async-current-process proc))
 101         (if (= 0 (process-exit-status proc))
 102             (if async-callback-for-process
 103                 (if async-callback
 104                     (prog1
 105                         (funcall async-callback proc)
 106                       (unless async-debug
 107                         (kill-buffer (current-buffer))))
 108                   (set (make-local-variable 'async-callback-value) proc)
 109                   (set (make-local-variable 'async-callback-value-set) t))
 110               (goto-char (point-max))
 111               (backward-sexp)
 112               (async-handle-result async-callback (read (current-buffer))
 113                                    (current-buffer)))
 114           (set (make-local-variable 'async-callback-value)
 115                (list 'error
 116                      (format "Async process '%s' failed with exit code %d"
 117                              (process-name proc) (process-exit-status proc))))
 118           (set (make-local-variable 'async-callback-value-set) t))))))
 119
 120 (defun async--receive-sexp (&optional stream)
 121   (let ((sexp (decode-coding-string (base64-decode-string
 122                                      (read stream)) 'utf-8-unix)))
 123     (if async-debug
 124         (message "Received sexp {{{%s}}}" (pp-to-string sexp)))
 125     (setq sexp (read sexp))
 126     (if async-debug
 127         (message "Read sexp {{{%s}}}" (pp-to-string sexp)))
 128     (eval sexp)))
 129
 130 (defun async--insert-sexp (sexp)
 131   (prin1 sexp (current-buffer))
 132   ;; Just in case the string we're sending might contain EOF
 133   (encode-coding-region (point-min) (point-max) 'utf-8-unix)
 134   (base64-encode-region (point-min) (point-max) t)
 135   (goto-char (point-min)) (insert ?\")
 136   (goto-char (point-max)) (insert ?\" ?\n))
 137
 138 (defun async--transmit-sexp (process sexp)
 139   (with-temp-buffer
 140     (if async-debug
 141         (message "Transmitting sexp {{{%s}}}" (pp-to-string sexp)))
 142     (async--insert-sexp sexp)
 143     (process-send-region process (point-min) (point-max))))
 144
 145 (defsubst async--value-printable-p (value)
 146   "Return non-nil if VALUE can be round-tripped to a string prepresentation."
 147   (condition-case nil
 148       (let* ((value-string (prin1-to-string value))
 149              (value-from-string (car (read-from-string value-string))))
 150         (equal value value-from-string))
 151     (error nil)))
 152
 153 (defun async--sanitize-closure (func)
 154   "If FUNC is a closure, delete unprintable lexicals from it."
 155   (when (eq (car-safe func) 'closure)
 156     (setf (cadr func)
 157           (or (loop for obj in (cadr func)
 158                     if (or (not (consp obj))
 159                            (async--value-printable-p (cdr obj)))
 160                     collect obj
 161                     else do
 162                     (when async-debug
 163                       (message "Sanitized var from closure: %s=%S"
 164                                (car obj) (cdr obj))))
 165               ;; A closure with no lexicals generally has this value
 166               ;; as its cadr, so we'll use that if everything gets
 167               ;; filtered out.
 168               '(t))))
 169   func)
 170
 171 (defsubst async--get-function (func)
 172   "Get the function definition of FUNC, whatever it is.
 173
 174 FUNC can be a variable name, "
 175   (indirect-function
 176    (cond
 177     ;; Quoted form => Extract value without evaluating since `(eval
 178     ;; (quote (closure ...)))' is an error.
 179     ((memq (car-safe func) '(quote function))
 180      (cadr func))
 181     ;; Anything else => eval it
 182     ;; (e.g. variable or function call)
 183     (t
 184      (eval func)))))
 185
 186 (defun async-batch-invoke ()
 187   "Called from the child Emacs process' command-line."
 188   (setq async-in-child-emacs t
 189         debug-on-error async-debug)
 190   (if debug-on-error
 191       (prin1 (funcall
 192               (async--receive-sexp (unless async-send-over-pipe
 193                                      command-line-args-left))))
 194     (condition-case err
 195         (prin1 (funcall
 196                 (async--receive-sexp (unless async-send-over-pipe
 197                                        command-line-args-left))))
 198       (error
 199        (prin1 (list 'async-signal err))))))
 200
 201 (defun async-ready (future)
 202   "Query a FUTURE to see if the ready is ready -- i.e., if no blocking
 203 would result from a call to `async-get' on that FUTURE."
 204   (and (memq (process-status future) '(exit signal))
 205        (with-current-buffer (process-buffer future)
 206          async-callback-value-set)))
 207
 208 (defun async-wait (future)
 209   "Wait for FUTURE to become ready."
 210   (while (not (async-ready future))
 211     (sit-for 0.05)))
 212
 213 (defun async-get (future)
 214   "Get the value from an asynchronously function when it is ready.
 215 FUTURE is returned by `async-start' or `async-start-process' when
 216 its FINISH-FUNC is nil."
 217   (async-wait future)
 218   (with-current-buffer (process-buffer future)
 219     (async-handle-result #'identity async-callback-value (current-buffer))))
 220
 221 (defun async-message-p (value)
 222   "Return true of VALUE is an async.el message packet."
 223   (and (listp value)
 224        (plist-get value :async-message)))
 225
 226 (defun async-send (&rest args)
 227   "Send the given messages to the asychronous Emacs PROCESS."
 228   (let ((args (append args '(:async-message t))))
 229     (if async-in-child-emacs
 230         (if async-callback
 231             (funcall async-callback args))
 232       (async--transmit-sexp (car args) (list 'quote (cdr args))))))
 233
 234 (defun async-receive (&rest args)
 235   "Send the given messages to the asychronous Emacs PROCESS."
 236   (async--receive-sexp))
 237
 238 ;;;###autoload
 239 (defun async-start-process (name program finish-func &rest program-args)
 240   "Start the executable PROGRAM asynchronously.  See `async-start'.
 241 PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
 242 process object when done.  If FINISH-FUNC is nil, the future
 243 object will return the process object when the program is
 244 finished."
 245   (let* ((buf (generate-new-buffer (concat "*" name "*")))
 246          (proc (let ((process-connection-type nil))
 247                  (apply #'start-process name buf program program-args))))
 248     (with-current-buffer buf
 249       (set (make-local-variable 'async-callback) finish-func)
 250       (set-process-sentinel proc #'async-when-done)
 251       (unless (string= name "emacs")
 252         (set (make-local-variable 'async-callback-for-process) t))
 253       proc)))
 254
 255 ;;;###autoload
 256 (defmacro async-start (start-func &optional finish-func)
 257   "Execute START-FUNC (often a lambda) in a subordinate Emacs process.
 258 When done, the return value is passed to FINISH-FUNC.  Example:
 259
 260     (async-start
 261        ;; What to do in the child process
 262        (lambda ()
 263          (message \"This is a test\")
 264          (sleep-for 3)
 265          222)
 266
 267        ;; What to do when it finishes
 268        (lambda (result)
 269          (message \"Async process done, result should be 222: %s\"
 270                   result)))
 271
 272 If FINISH-FUNC is nil or missing, a future is returned that can
 273 be inspected using `async-get', blocking until the value is
 274 ready.  Example:
 275
 276     (let ((proc (async-start
 277                    ;; What to do in the child process
 278                    (lambda ()
 279                      (message \"This is a test\")
 280                      (sleep-for 3)
 281                      222))))
 282
 283         (message \"I'm going to do some work here\") ;; ....
 284
 285         (message \"Waiting on async process, result should be 222: %s\"
 286                  (async-get proc)))
 287
 288 If you don't want to use a callback, and you don't care about any
 289 return value form the child process, pass the `ignore' symbol as
 290 the second argument (if you don't, and never call `async-get', it
 291 will leave *emacs* process buffers hanging around):
 292
 293     (async-start
 294      (lambda ()
 295        (delete-file \"a remote file on a slow link\" nil))
 296      'ignore)
 297
 298 Note: Even when FINISH-FUNC is present, a future is still
 299 returned except that it yields no value (since the value is
 300 passed to FINISH-FUNC).  Call `async-get' on such a future always
 301 returns nil.  It can still be useful, however, as an argument to
 302 `async-ready' or `async-wait'."
 303   (require 'find-func)
 304   (let* ((procvar (make-symbol "proc"))
 305          ;; Evaluate START-FUNC and resolve it to an actual function
 306          ;; definition.
 307          (start-func
 308           (async--get-function start-func)))
 309     (unless (functionp start-func)
 310       (error "Start-func is not a function: %S" start-func))
 311     `(let* ((sexp (async--sanitize-closure #',start-func))
 312             (,procvar
 313              (async-start-process
 314               "emacs" (file-truename
 315                        (expand-file-name invocation-name
 316                                          invocation-directory))
 317               ,finish-func
 318               "-Q" "-l" ,(funcall (symbol-function 'find-library-name)
 319                                   "async")
 320               "-batch" "-f" "async-batch-invoke"
 321               (if async-send-over-pipe
 322                   "<none>"
 323                 (with-temp-buffer
 324                   (async--insert-sexp (list 'quote sexp))
 325                   (buffer-string))))))
 326        (if async-send-over-pipe
 327            (async--transmit-sexp ,procvar (list 'quote sexp)))
 328        ,procvar)))
 329
 330 (defmacro async-sandbox(func)
 331   "Evaluate FUNC in a separate Emacs process, synchronously."
 332   `(async-get (async-start ,func)))
 333
 334 (provide 'async)
 335
 336 ;;; async.el ends here