X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/374f514ca34200a58db5ef63baf7088da748aef9..0b8fbed11210331e39f1f7049dcc3490d11dce71:/async.el

diff --git a/async.el b/async.el
index 40663da1e..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~2013 John Wiegley
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
 
 ;; Author: John Wiegley <jwiegley@gmail.com>
 ;; Created: 18 Jun 2012
-;; Version: 1.1
+;; Version: 1.6
+
 ;; Keywords: async
 ;; X-URL: https://github.com/jwiegley/emacs-async
 
@@ -42,6 +43,7 @@
 (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)
@@ -93,8 +95,8 @@ as follows:
       (unless async-debug
         (kill-buffer buf)))))
 
-(defun async-when-done (proc &optional change)
-  "Process sentinal used to retrieve the value from the child process."
+(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))
@@ -119,7 +121,9 @@ as follows:
 
 (defun async--receive-sexp (&optional stream)
   (let ((sexp (decode-coding-string (base64-decode-string
-                                     (read stream)) 'utf-8-unix)))
+                                     (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))
@@ -128,12 +132,16 @@ as follows:
     (eval sexp)))
 
 (defun async--insert-sexp (sexp)
-  (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))
+  (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
@@ -142,65 +150,23 @@ as follows:
     (async--insert-sexp sexp)
     (process-send-region process (point-min) (point-max))))
 
-(defsubst async--value-printable-p (value)
-  "Return non-nil if VALUE can be round-tripped to a string prepresentation."
-  (condition-case nil
-      (let* ((value-string (prin1-to-string value))
-             (value-from-string (car (read-from-string value-string))))
-        (equal value value-from-string))
-    (error nil)))
-
-(defun async--sanitize-closure (func)
-  "If FUNC is a closure, delete unprintable lexicals from it."
-  (when (eq (car-safe func) 'closure)
-    (setf (cadr func)
-          (or (loop for obj in (cadr func)
-                    if (or (not (consp obj))
-                           (async--value-printable-p (cdr obj)))
-                    collect obj
-                    else do
-                    (when async-debug
-                      (message "Sanitized var from closure: %s=%S"
-                               (car obj) (cdr obj))))
-              ;; A closure with no lexicals generally has this value
-              ;; as its cadr, so we'll use that if everything gets
-              ;; filtered out.
-              '(t))))
-  func)
-
-(defsubst async--get-function (func)
-  "Get the function definition of FUNC, whatever it is.
-
-FUNC can be a variable name, a function definition, or an
-expression that evaluates to a function.
-
-This exists to get around the fact that closures are not
-self-quoting, so calling `eval' on them results in an error."
-  (indirect-function
-   (cond
-    ;; Quoted form => Extract value without evaluating since `(eval
-    ;; (quote (closure ...)))' is an error.
-    ((memq (car-safe func) '(quote function))
-     (cadr func))
-    ;; Anything else => eval it
-    ;; (e.g. variable or function call)
-    (t
-     (eval func)))))
-
 (defun async-batch-invoke ()
   "Called from the child Emacs process' command-line."
-  (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))))))
+  ;; 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
@@ -235,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))
 
@@ -245,7 +211,8 @@ 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 (let ((process-connection-type nil))
                  (apply #'start-process name buf program program-args))))
@@ -257,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:
 
@@ -290,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):
 
@@ -304,32 +271,28 @@ 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"))
-         ;; Evaluate START-FUNC and resolve it to an actual function
-         ;; definition.
-         (start-func
-          (async--get-function start-func)))
-    (unless (functionp start-func)
-      (error "Start-func is not a function: %S" start-func))
-    `(let* ((sexp (async--sanitize-closure #',start-func))
-            (,procvar
-             (async-start-process
-              "emacs" (file-truename
-                       (expand-file-name invocation-name
-                                         invocation-directory))
-              ,finish-func
-              "-Q" "-l" ,(funcall (symbol-function 'find-library-name)
-                                  "async")
-              "-batch" "-f" "async-batch-invoke"
-              (if async-send-over-pipe
-                  "<none>"
-                (with-temp-buffer
-                  (async--insert-sexp (list 'quote sexp))
-                  (buffer-string))))))
-       (if async-send-over-pipe
-           (async--transmit-sexp ,procvar (list 'quote sexp)))
-       ,procvar)))
+  (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
+               "<none>"
+               (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."