.emacs.d.git - Gitblit

Chizi123

2018-11-21 e75a20334813452c6912c090d70a0de2c805f94d

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