mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-18 434b46beff1c5ec01cbefd5273d89971a82d6bab
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