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

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