| commit | author | age | ||
| 5cb5f7 | 1 | ;;; async.el --- Asynchronous processing in Emacs -*- lexical-binding: t -*- |
| C | 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.9.3 | |
| 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 | ||
| 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 | ||
| 32 | ;;; Code: | |
| 33 | ||
| 34 | (eval-when-compile (require 'cl-lib)) | |
| 35 | ||
| 36 | (defgroup async nil | |
| 37 | "Simple asynchronous processing in Emacs" | |
| 38 | :group 'emacs) | |
| 39 | ||
| 40 | (defcustom async-variables-noprops-function #'async-variables-noprops | |
| 41 | "Default function to remove text properties in variables." | |
| 42 | :group 'async | |
| 43 | :type 'function) | |
| 44 | ||
| 45 | (defvar async-debug nil) | |
| 46 | (defvar async-send-over-pipe t) | |
| 47 | (defvar async-in-child-emacs nil) | |
| 48 | (defvar async-callback nil) | |
| 49 | (defvar async-callback-for-process nil) | |
| 50 | (defvar async-callback-value nil) | |
| 51 | (defvar async-callback-value-set nil) | |
| 52 | (defvar async-current-process nil) | |
| 53 | (defvar async--procvar nil) | |
| 54 | ||
| 55 | (defun async-variables-noprops (sequence) | |
| 56 | "Remove text properties in SEQUENCE. | |
| 57 | ||
| 58 | Argument SEQUENCE may be a list or a string, if anything else it | |
| 59 | is returned unmodified. | |
| 60 | ||
| 61 | Note that this is a naive function that doesn't remove text properties | |
| 62 | in SEQUENCE recursively, only at the first level which suffice in most | |
| 63 | cases." | |
| 64 | (cond ((stringp sequence) | |
| 65 | (substring-no-properties sequence)) | |
| 66 | ((listp sequence) | |
| 67 | (cl-loop for elm in sequence | |
| 68 | if (stringp elm) | |
| 69 | collect (substring-no-properties elm) | |
| 70 | else collect elm)) | |
| 71 | (t sequence))) | |
| 72 | ||
| 73 | (defun async-inject-variables | |
| 74 | (include-regexp &optional predicate exclude-regexp noprops) | |
| 75 | "Return a `setq' form that replicates part of the calling environment. | |
| 76 | ||
| 77 | It sets the value for every variable matching INCLUDE-REGEXP and | |
| 78 | also PREDICATE. It will not perform injection for any variable | |
| 79 | matching EXCLUDE-REGEXP (if present) or representing a syntax-table | |
| 80 | i.e. ending by \"-syntax-table\". | |
| 81 | When NOPROPS is non nil it tries to strip out text properties of each | |
| 82 | variable's value with `async-variables-noprops-function'. | |
| 83 | ||
| 84 | It is intended to be used as follows: | |
| 85 | ||
| 86 | (async-start | |
| 87 | `(lambda () | |
| 88 | (require 'smtpmail) | |
| 89 | (with-temp-buffer | |
| 90 | (insert ,(buffer-substring-no-properties (point-min) (point-max))) | |
| 91 | ;; Pass in the variable environment for smtpmail | |
| 92 | ,(async-inject-variables \"\\`\\(smtpmail\\|\\(user-\\)?mail\\)-\") | |
| 93 | (smtpmail-send-it))) | |
| 94 | 'ignore)" | |
| 95 | `(setq | |
| 96 | ,@(let (bindings) | |
| 97 | (mapatoms | |
| 98 | (lambda (sym) | |
| 99 | (let* ((sname (and (boundp sym) (symbol-name sym))) | |
| 100 | (value (and sname (symbol-value sym)))) | |
| 101 | (when (and sname | |
| 102 | (or (null include-regexp) | |
| 103 | (string-match include-regexp sname)) | |
| 104 | (or (null exclude-regexp) | |
| 105 | (not (string-match exclude-regexp sname))) | |
| 106 | (not (string-match "-syntax-table\\'" sname))) | |
| 107 | (unless (or (stringp value) | |
| 108 | (memq value '(nil t)) | |
| 109 | (numberp value) | |
| 110 | (vectorp value)) | |
| 111 | (setq value `(quote ,value))) | |
| 112 | (when noprops | |
| 113 | (setq value (funcall async-variables-noprops-function | |
| 114 | value))) | |
| 115 | (when (or (null predicate) | |
| 116 | (funcall predicate sym)) | |
| 117 | (setq bindings (cons value bindings) | |
| 118 | bindings (cons sym bindings))))))) | |
| 119 | bindings))) | |
| 120 | ||
| 121 | (defalias 'async-inject-environment 'async-inject-variables) | |
| 122 | ||
| 123 | (defun async-handle-result (func result buf) | |
| 124 | (if (null func) | |
| 125 | (progn | |
| 126 | (set (make-local-variable 'async-callback-value) result) | |
| 127 | (set (make-local-variable 'async-callback-value-set) t)) | |
| 128 | (unwind-protect | |
| 129 | (if (and (listp result) | |
| 130 | (eq 'async-signal (nth 0 result))) | |
| 131 | (signal (car (nth 1 result)) | |
| 132 | (cdr (nth 1 result))) | |
| 133 | (funcall func result)) | |
| 134 | (unless async-debug | |
| 135 | (kill-buffer buf))))) | |
| 136 | ||
| 137 | (defun async-when-done (proc &optional _change) | |
| 138 | "Process sentinel used to retrieve the value from the child process." | |
| 139 | (when (eq 'exit (process-status proc)) | |
| 140 | (with-current-buffer (process-buffer proc) | |
| 141 | (let ((async-current-process proc)) | |
| 142 | (if (= 0 (process-exit-status proc)) | |
| 143 | (if async-callback-for-process | |
| 144 | (if async-callback | |
| 145 | (prog1 | |
| 146 | (funcall async-callback proc) | |
| 147 | (unless async-debug | |
| 148 | (kill-buffer (current-buffer)))) | |
| 149 | (set (make-local-variable 'async-callback-value) proc) | |
| 150 | (set (make-local-variable 'async-callback-value-set) t)) | |
| 151 | (goto-char (point-max)) | |
| 152 | (backward-sexp) | |
| 153 | (async-handle-result async-callback (read (current-buffer)) | |
| 154 | (current-buffer))) | |
| 155 | (set (make-local-variable 'async-callback-value) | |
| 156 | (list 'error | |
| 157 | (format "Async process '%s' failed with exit code %d" | |
| 158 | (process-name proc) (process-exit-status proc)))) | |
| 159 | (set (make-local-variable 'async-callback-value-set) t)))))) | |
| 160 | ||
| 161 | (defun async--receive-sexp (&optional stream) | |
| 162 | (let ((sexp (decode-coding-string (base64-decode-string | |
| 163 | (read stream)) 'utf-8-auto)) | |
| 164 | ;; Parent expects UTF-8 encoded text. | |
| 165 | (coding-system-for-write 'utf-8-auto)) | |
| 166 | (if async-debug | |
| 167 | (message "Received sexp {{{%s}}}" (pp-to-string sexp))) | |
| 168 | (setq sexp (read sexp)) | |
| 169 | (if async-debug | |
| 170 | (message "Read sexp {{{%s}}}" (pp-to-string sexp))) | |
| 171 | (eval sexp))) | |
| 172 | ||
| 173 | (defun async--insert-sexp (sexp) | |
| 174 | (let (print-level | |
| 175 | print-length | |
| 176 | (print-escape-nonascii t) | |
| 177 | (print-circle t)) | |
| 178 | (prin1 sexp (current-buffer)) | |
| 179 | ;; Just in case the string we're sending might contain EOF | |
| 180 | (encode-coding-region (point-min) (point-max) 'utf-8-auto) | |
| 181 | (base64-encode-region (point-min) (point-max) t) | |
| 182 | (goto-char (point-min)) (insert ?\") | |
| 183 | (goto-char (point-max)) (insert ?\" ?\n))) | |
| 184 | ||
| 185 | (defun async--transmit-sexp (process sexp) | |
| 186 | (with-temp-buffer | |
| 187 | (if async-debug | |
| 188 | (message "Transmitting sexp {{{%s}}}" (pp-to-string sexp))) | |
| 189 | (async--insert-sexp sexp) | |
| 190 | (process-send-region process (point-min) (point-max)))) | |
| 191 | ||
| 192 | (defun async-batch-invoke () | |
| 193 | "Called from the child Emacs process' command-line." | |
| 194 | ;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent | |
| 195 | ;; process expects. | |
| 196 | (let ((coding-system-for-write 'utf-8-auto)) | |
| 197 | (setq async-in-child-emacs t | |
| 198 | debug-on-error async-debug) | |
| 199 | (if debug-on-error | |
| 200 | (prin1 (funcall | |
| 201 | (async--receive-sexp (unless async-send-over-pipe | |
| 202 | command-line-args-left)))) | |
| 203 | (condition-case err | |
| 204 | (prin1 (funcall | |
| 205 | (async--receive-sexp (unless async-send-over-pipe | |
| 206 | command-line-args-left)))) | |
| 207 | (error | |
| 208 | (prin1 (list 'async-signal err))))))) | |
| 209 | ||
| 210 | (defun async-ready (future) | |
| 211 | "Query a FUTURE to see if it is ready. | |
| 212 | ||
| 213 | I.e., if no blocking | |
| 214 | would result from a call to `async-get' on that FUTURE." | |
| 215 | (and (memq (process-status future) '(exit signal)) | |
| 216 | (let ((buf (process-buffer future))) | |
| 217 | (if (buffer-live-p buf) | |
| 218 | (with-current-buffer buf | |
| 219 | async-callback-value-set) | |
| 220 | t)))) | |
| 221 | ||
| 222 | (defun async-wait (future) | |
| 223 | "Wait for FUTURE to become ready." | |
| 224 | (while (not (async-ready future)) | |
| 225 | (sleep-for 0.05))) | |
| 226 | ||
| 227 | (defun async-get (future) | |
| 228 | "Get the value from process FUTURE when it is ready. | |
| 229 | FUTURE is returned by `async-start' or `async-start-process' when | |
| 230 | its FINISH-FUNC is nil." | |
| 231 | (and future (async-wait future)) | |
| 232 | (let ((buf (process-buffer future))) | |
| 233 | (when (buffer-live-p buf) | |
| 234 | (with-current-buffer buf | |
| 235 | (async-handle-result | |
| 236 | #'identity async-callback-value (current-buffer)))))) | |
| 237 | ||
| 238 | (defun async-message-p (value) | |
| 239 | "Return true of VALUE is an async.el message packet." | |
| 240 | (and (listp value) | |
| 241 | (plist-get value :async-message))) | |
| 242 | ||
| 243 | (defun async-send (&rest args) | |
| 244 | "Send the given messages to the asychronous Emacs PROCESS." | |
| 245 | (let ((args (append args '(:async-message t)))) | |
| 246 | (if async-in-child-emacs | |
| 247 | (if async-callback | |
| 248 | (funcall async-callback args)) | |
| 249 | (async--transmit-sexp (car args) (list 'quote (cdr args)))))) | |
| 250 | ||
| 251 | (defun async-receive () | |
| 252 | "Send the given messages to the asychronous Emacs PROCESS." | |
| 253 | (async--receive-sexp)) | |
| 254 | ||
| 255 | ;;;###autoload | |
| 256 | (defun async-start-process (name program finish-func &rest program-args) | |
| 257 | "Start the executable PROGRAM asynchronously. See `async-start'. | |
| 258 | PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the | |
| 259 | process object when done. If FINISH-FUNC is nil, the future | |
| 260 | object will return the process object when the program is | |
| 261 | finished. Set DEFAULT-DIRECTORY to change PROGRAM's current | |
| 262 | working directory." | |
| 263 | (let* ((buf (generate-new-buffer (concat "*" name "*"))) | |
| 264 | (proc (let ((process-connection-type nil)) | |
| 265 | (apply #'start-process name buf program program-args)))) | |
| 266 | (with-current-buffer buf | |
| 267 | (set (make-local-variable 'async-callback) finish-func) | |
| 268 | (set-process-sentinel proc #'async-when-done) | |
| 269 | (unless (string= name "emacs") | |
| 270 | (set (make-local-variable 'async-callback-for-process) t)) | |
| 271 | proc))) | |
| 272 | ||
| 273 | (defvar async-quiet-switch "-Q" | |
| 274 | "The Emacs parameter to use to call emacs without config. | |
| 275 | Can be one of \"-Q\" or \"-q\". | |
| 276 | Default is \"-Q\" but it is sometimes useful to use \"-q\" to have a | |
| 277 | enhanced config or some more variables loaded.") | |
| 278 | ||
| 279 | ;;;###autoload | |
| 280 | (defun async-start (start-func &optional finish-func) | |
| 281 | "Execute START-FUNC (often a lambda) in a subordinate Emacs process. | |
| 282 | When done, the return value is passed to FINISH-FUNC. Example: | |
| 283 | ||
| 284 | (async-start | |
| 285 | ;; What to do in the child process | |
| 286 | (lambda () | |
| 287 | (message \"This is a test\") | |
| 288 | (sleep-for 3) | |
| 289 | 222) | |
| 290 | ||
| 291 | ;; What to do when it finishes | |
| 292 | (lambda (result) | |
| 293 | (message \"Async process done, result should be 222: %s\" | |
| 294 | result))) | |
| 295 | ||
| 296 | If FINISH-FUNC is nil or missing, a future is returned that can | |
| 297 | be inspected using `async-get', blocking until the value is | |
| 298 | ready. Example: | |
| 299 | ||
| 300 | (let ((proc (async-start | |
| 301 | ;; What to do in the child process | |
| 302 | (lambda () | |
| 303 | (message \"This is a test\") | |
| 304 | (sleep-for 3) | |
| 305 | 222)))) | |
| 306 | ||
| 307 | (message \"I'm going to do some work here\") ;; .... | |
| 308 | ||
| 309 | (message \"Waiting on async process, result should be 222: %s\" | |
| 310 | (async-get proc))) | |
| 311 | ||
| 312 | If you don't want to use a callback, and you don't care about any | |
| 313 | return value from the child process, pass the `ignore' symbol as | |
| 314 | the second argument (if you don't, and never call `async-get', it | |
| 315 | will leave *emacs* process buffers hanging around): | |
| 316 | ||
| 317 | (async-start | |
| 318 | (lambda () | |
| 319 | (delete-file \"a remote file on a slow link\" nil)) | |
| 320 | 'ignore) | |
| 321 | ||
| 322 | Note: Even when FINISH-FUNC is present, a future is still | |
| 323 | returned except that it yields no value (since the value is | |
| 324 | passed to FINISH-FUNC). Call `async-get' on such a future always | |
| 325 | returns nil. It can still be useful, however, as an argument to | |
| 326 | `async-ready' or `async-wait'." | |
| 327 | (let ((sexp start-func) | |
| 328 | ;; Subordinate Emacs will send text encoded in UTF-8. | |
| 329 | (coding-system-for-read 'utf-8-auto)) | |
| 330 | (setq async--procvar | |
| 331 | (async-start-process | |
| 332 | "emacs" (file-truename | |
| 333 | (expand-file-name invocation-name | |
| 334 | invocation-directory)) | |
| 335 | finish-func | |
| 336 | async-quiet-switch "-l" | |
| 337 | ;; Using `locate-library' ensure we use the right file | |
| 338 | ;; when the .elc have been deleted. | |
| 339 | (locate-library "async") | |
| 340 | "-batch" "-f" "async-batch-invoke" | |
| 341 | (if async-send-over-pipe | |
| 342 | "<none>" | |
| 343 | (with-temp-buffer | |
| 344 | (async--insert-sexp (list 'quote sexp)) | |
| 345 | (buffer-string))))) | |
| 346 | (if async-send-over-pipe | |
| 347 | (async--transmit-sexp async--procvar (list 'quote sexp))) | |
| 348 | async--procvar)) | |
| 349 | ||
| 350 | (defmacro async-sandbox(func) | |
| 351 | "Evaluate FUNC in a separate Emacs process, synchronously." | |
| 352 | `(async-get (async-start ,func))) | |
| 353 | ||
| 354 | (defun async--fold-left (fn forms bindings) | |
| 355 | (let ((res forms)) | |
| 356 | (dolist (binding bindings) | |
| 357 | (setq res (funcall fn res | |
| 358 | (if (listp binding) | |
| 359 | binding | |
| 360 | (list binding))))) | |
| 361 | res)) | |
| 362 | ||
| 363 | (defmacro async-let (bindings &rest forms) | |
| 364 | "Implements `let', but each binding is established asynchronously. | |
| 365 | For example: | |
| 366 | ||
| 367 | (async-let ((x (foo)) | |
| 368 | (y (bar))) | |
| 369 | (message \"%s %s\" x y)) | |
| 370 | ||
| 371 | expands to ==> | |
| 372 | ||
| 373 | (async-start (foo) | |
| 374 | (lambda (x) | |
| 375 | (async-start (bar) | |
| 376 | (lambda (y) | |
| 377 | (message \"%s %s\" x y)))))" | |
| 378 | (declare (indent 1)) | |
| 379 | (async--fold-left | |
| 380 | (lambda (acc binding) | |
| 381 | (let ((fun (pcase (cadr binding) | |
| 382 | ((and (pred functionp) f) f) | |
| 383 | (f `(lambda () ,f))))) | |
| 384 | `(async-start ,fun | |
| 385 | (lambda (,(car binding)) | |
| 386 | ,acc)))) | |
| 387 | `(progn ,@forms) | |
| 388 | (reverse bindings))) | |
| 389 | ||
| 390 | (provide 'async) | |
| 391 | ||
| 392 | ;;; async.el ends here | |
