X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/7ba4f40ef0a013a9761accf805317f7b68c2c4b4..228ec4bb351a9e14e338b9cb09eeb4809957c909:/async.el diff --git a/async.el b/async.el index f9c561cb7..dc732707b 100644 --- a/async.el +++ b/async.el @@ -1,10 +1,11 @@ -;;; 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.1 +;; Version: 1.6 + ;; Keywords: async ;; X-URL: https://github.com/jwiegley/emacs-async @@ -35,13 +36,14 @@ :group 'emacs) (defvar async-debug nil) -(defvar async-send-over-pipe 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) @@ -79,8 +81,22 @@ as follows: (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) (let ((async-current-process proc)) @@ -95,37 +111,37 @@ as follows: (set (make-local-variable 'async-callback-value-set) t)) (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))) - (signal (cadr result) - (cddr result))) - (if async-callback - (prog1 - (funcall async-callback result) - (unless async-debug - (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 process '%s' failed with exit code %d" - (process-name proc) (process-exit-status proc))))))) + (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 (read (base64-decode-string (read 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) - (prin1 sexp (current-buffer)) - ;; Just in case the string we're sending might contain EOF - (base64-encode-region (point-min) (point-max) t) - (goto-char (point-min)) (insert ?\") - (goto-char (point-max)) (insert ?\" ?\n)) + (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 @@ -136,20 +152,28 @@ as follows: (defun async-batch-invoke () "Called from the child Emacs process' command-line." - (setq async-in-child-emacs t) - (condition-case err - (prin1 (funcall - (async--receive-sexp (unless async-send-over-pipe - command-line-args-left)))) - (error - (backtrace) - (prin1 `(async-signal . ,err))))) + ;; 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 (eq 'exit (process-status future)) - async-callback-value-set)) + (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." @@ -162,9 +186,7 @@ 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) - (prog1 - async-callback-value - (kill-buffer (current-buffer))))) + (async-handle-result #'identity async-callback-value (current-buffer)))) (defun async-message-p (value) "Return true of VALUE is an async.el message packet." @@ -179,7 +201,7 @@ its FINISH-FUNC is nil." (funcall async-callback args)) (async--transmit-sexp (car args) (list 'quote (cdr args)))))) -(defun async-receive (&rest args) +(defun async-receive () "Send the given messages to the asychronous Emacs PROCESS." (async--receive-sexp)) @@ -189,9 +211,11 @@ its FINISH-FUNC is nil." 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." +finished. Set DEFAULT-DIRECTORY to change PROGRAM's current +working directory." (let* ((buf (generate-new-buffer (concat "*" name "*"))) - (proc (apply #'start-process name buf program program-args))) + (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) @@ -200,7 +224,7 @@ finished." proc))) ;;;###autoload -(defmacro async-start (start-func &optional finish-func) +(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: @@ -233,7 +257,7 @@ ready. Example: (async-get proc))) If you don't want to use a callback, and you don't care about any -return value form the child process, pass the `ignore' symbol as +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): @@ -247,118 +271,32 @@ 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'." - (require 'find-func) - (let ((procvar (make-symbol "proc"))) - `(let* ((sexp ,start-func) - (,procvar - (async-start-process - "emacs" (expand-file-name invocation-name - invocation-directory) - ,finish-func - "-Q" "-l" ,(find-library-name "async") - "-batch" "-f" "async-batch-invoke" - ,@(unless async-send-over-pipe - '((with-temp-buffer - (async--insert-sexp (list 'quote sexp)) - (buffer-string))))))) - ,@(if async-send-over-pipe - `((async--transmit-sexp ,procvar (list 'quote sexp)))) - ,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")) - -(defun async-test-4 () - (interactive) - (message "Starting async-test-4...") - (async-start-process "sleep" "sleep" - ;; What to do when it finishes - (lambda (proc) - (message "Sleep done, exit code was %d" - (process-exit-status proc))) - "3") - (message "Starting async-test-4...done")) - -(defun async-test-5 () - (interactive) - (message "Starting async-test-5...") - (let ((proc - (async-start - ;; What to do in the child process - (lambda () - (message "This is a test, sending message") - (async-send :hello "world") - ;; wait for a message - (let ((msg (async-receive))) - (message "Child got message: %s" - (plist-get msg :goodbye))) - (sleep-for 3) - 222) - - ;; What to do when it finishes - (lambda (result) - (if (async-message-p result) - (message "Got hello from child process: %s" - (plist-get result :hello)) - (message "Async process done, result should be 222: %s" - result)))))) - (async-send proc :goodbye "everyone")) - (message "Starting async-test-5...done")) - -(defun async-test-6 () - (interactive) - (message "Starting async-test-6...") - (async-start - ;; What to do in the child process - `(lambda () - ,(async-inject-variables "\\`user-mail-address\\'") - (format "user-mail-address = %s" user-mail-address)) - - ;; What to do when it finishes - (lambda (result) - (message "Async process done: %s" result)))) + (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)