Klimi's new dotfiles with stow.
25'ten fazla konu seçemezsiniz Konular bir harf veya rakamla başlamalı, kısa çizgiler ('-') içerebilir ve en fazla 35 karakter uzunluğunda olabilir.

408 satır
15 KiB

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