forked from mirrors/org-mode
org-macs: Add an async command execution system
* lisp/org-macs.el (org-async--stack, org-async--wait-queue, org-async-process-limit, org-async-timeout, org-async-check-timeout-interval, org-async--counter, org-async-call, org-async--sentinel, org-async--cleanup-process, org-async--execute-callback, org-async--monitor-scheduled, org-async--monitor): Introduce an asynchronous command execution system.
This commit is contained in:
parent
2917fe4e35
commit
6b6aff2ef2
171
lisp/org-macs.el
171
lisp/org-macs.el
|
@ -368,6 +368,177 @@ If EXCLUDE-TMP is non-nil, ignore temporary buffers."
|
||||||
nil))
|
nil))
|
||||||
(buffer-list)))))
|
(buffer-list)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Async stack
|
||||||
|
|
||||||
|
(defvar org-async--stack nil
|
||||||
|
"List of (%PROCESS :start-time %FLOAT :success %FUN :failure %FUN :timeout %FLOAT :buffer %BUFFER) forms.")
|
||||||
|
|
||||||
|
(defvar org-async--wait-queue nil
|
||||||
|
"List of (%PROCESS :success %FUN :failure %FUN :timeout %FLOAT :buffer %BUFFER) forms.")
|
||||||
|
|
||||||
|
(defvar org-async-process-limit 4
|
||||||
|
"Maximum number of processes to run at once.")
|
||||||
|
|
||||||
|
(defvar org-async-timeout 120
|
||||||
|
"Default timeout for a process started via `org-async-queue'.")
|
||||||
|
|
||||||
|
(defvar org-async-check-timeout-interval 1
|
||||||
|
"Check for processes which have exceeded their timeout every this many seconds.")
|
||||||
|
|
||||||
|
(defvar org-async--counter 0)
|
||||||
|
|
||||||
|
(cl-defun org-async-call (proc &key success failure filter buffer info timeout now
|
||||||
|
(dir default-directory))
|
||||||
|
"Start PROC and register it with callbacks SUCCESS and FAILURE.
|
||||||
|
|
||||||
|
PROC can be a process, string, or list. A string will be run as
|
||||||
|
a shell command, with `start-process-shell-command' and a list
|
||||||
|
run using `start-process' with the car as the command and the cdr
|
||||||
|
as the arguments. The process will be executed in DIR (if set)
|
||||||
|
or `default-directory'.
|
||||||
|
|
||||||
|
When BUFFER is provided, the output of PROC will be directed to it.
|
||||||
|
Shoud BUFFER be t, then a temp buffer will be created and removed
|
||||||
|
during `org-async--cleanup-process'.
|
||||||
|
|
||||||
|
SUCCESS and FAILURE can be any form accepted by `org-async--execute-callback',
|
||||||
|
namely:
|
||||||
|
- A string, which is used a `message' string with the exit-code,
|
||||||
|
process-buffer, and INFO as arguments.
|
||||||
|
- A function, which is called with exit-code, process-buffer,
|
||||||
|
and INFO as arguments.
|
||||||
|
- A list, which is used as an argument list for a new `org-async-call' invocation.
|
||||||
|
- nil, which does nothing.
|
||||||
|
|
||||||
|
When PROC succeeds by exiting with an exit code of zero, the SUCCESS
|
||||||
|
callback will be run. Should PROC fail, or be killed, or the process
|
||||||
|
runs for more than TIMEOUT seconds, the FAILURE callback will be run.
|
||||||
|
|
||||||
|
When NOW is non-nil, the PROC is started immediately, regardless
|
||||||
|
of `org-async-process-limit'."
|
||||||
|
(if (or now (< (length org-async--stack) org-async-process-limit))
|
||||||
|
(let ((proc
|
||||||
|
(let ((default-directory (or dir default-directory)))
|
||||||
|
(cond ((processp proc) proc)
|
||||||
|
((stringp proc)
|
||||||
|
(start-process-shell-command
|
||||||
|
(format "org-async-%d" (cl-incf org-async--counter))
|
||||||
|
buffer proc))
|
||||||
|
((consp proc)
|
||||||
|
(apply #'start-process
|
||||||
|
(format "org-async-%s-%d"
|
||||||
|
(car proc) (cl-incf org-async--counter))
|
||||||
|
buffer proc))
|
||||||
|
(t (error "Asycnc process input %S not a recognised format"
|
||||||
|
proc)))))
|
||||||
|
(timeout (or timeout org-async-timeout)))
|
||||||
|
(set-process-sentinel proc #'org-async--sentinel)
|
||||||
|
(when filter
|
||||||
|
(set-process-filter proc filter))
|
||||||
|
(push (list proc
|
||||||
|
:success success
|
||||||
|
:failure failure
|
||||||
|
:timeout timeout
|
||||||
|
:buffer (if (eq buffer t)
|
||||||
|
(cons :temp (generate-new-buffer " *temp*" t))
|
||||||
|
buffer)
|
||||||
|
:info info
|
||||||
|
:start-time (float-time))
|
||||||
|
org-async--stack)
|
||||||
|
(org-async--monitor t)
|
||||||
|
(car org-async--stack))
|
||||||
|
(setq org-async--wait-queue
|
||||||
|
(append org-async--wait-queue
|
||||||
|
(list (list proc
|
||||||
|
:success success
|
||||||
|
:failure failure
|
||||||
|
:dir dir
|
||||||
|
:info info
|
||||||
|
:buffer buffer
|
||||||
|
:timeout timeout
|
||||||
|
:filter filter))))
|
||||||
|
(last org-async--wait-queue)))
|
||||||
|
|
||||||
|
(defun org-async--sentinel (process _signal)
|
||||||
|
"Watch PROCESS for death, and cleanup accordingly.
|
||||||
|
When a signal is recieved, the status of PROCESS is checked.
|
||||||
|
Should the it have an exit status, with status code 0,
|
||||||
|
`org-async--cleanup-process' is run with the \"failed\" argument
|
||||||
|
unset. Should the process have finished in any other manner,
|
||||||
|
`org-async--cleanup-process' is run with the \"failed\" argument."
|
||||||
|
(pcase (process-status process)
|
||||||
|
((and 'exit (guard (= 0 (process-exit-status process))))
|
||||||
|
(org-async--cleanup-process process))
|
||||||
|
((or 'exit 'signal 'failed)
|
||||||
|
(org-async--cleanup-process process 'failed))))
|
||||||
|
|
||||||
|
(defun org-async--cleanup-process (process &optional failed)
|
||||||
|
"Remove PROCESS from the async stack, and run its callback.
|
||||||
|
If the exit code of PROCESS is zero and FAILED is non-nil, then
|
||||||
|
the success callback is run (via `org-async--execute-callback').
|
||||||
|
Otherwise, the failure callback is run."
|
||||||
|
(when (assq process org-async--stack)
|
||||||
|
(let* ((proc-info (cdr (assq process org-async--stack)))
|
||||||
|
(buffer-val (plist-get proc-info :buffer))
|
||||||
|
(proc-buf (if (consp buffer-val) (cdr buffer-val) buffer-val)))
|
||||||
|
(setq org-async--stack
|
||||||
|
(delq (assq process org-async--stack) org-async--stack))
|
||||||
|
(org-async--execute-callback
|
||||||
|
(plist-get
|
||||||
|
proc-info
|
||||||
|
(if (and (not failed)
|
||||||
|
(= 0 (process-exit-status process)))
|
||||||
|
:success :failure))
|
||||||
|
(process-exit-status process)
|
||||||
|
proc-buf
|
||||||
|
(plist-get proc-info :info))
|
||||||
|
(when (and (consp buffer-val) (eq :temp (car buffer-val)))
|
||||||
|
(kill-buffer proc-buf)))
|
||||||
|
(when (and org-async--wait-queue
|
||||||
|
(< org-async-process-limit (length org-async--stack)))
|
||||||
|
(apply #'org-async-call (pop org-async--wait-queue)))))
|
||||||
|
|
||||||
|
(defun org-async--execute-callback (callback exit-code process-buffer info)
|
||||||
|
"Run CALLBACK with EXIT-CODE, PROCESS-BUFFER, and INFO.
|
||||||
|
CALLBACK can take one of four forms:
|
||||||
|
- A string, which is used a `message' string with EXIT-CODE,
|
||||||
|
PROCESS-BUFFER, and INFO as arguments.
|
||||||
|
- A function, which is called with EXIT-CODE, PROCESS-BUFFER,
|
||||||
|
and INFO as arguments.
|
||||||
|
- A list, which is used as an argument list for a new `org-async-call' invocation.
|
||||||
|
- nil, which does nothing."
|
||||||
|
(cond
|
||||||
|
((stringp callback)
|
||||||
|
(message callback exit-code process-buffer info))
|
||||||
|
((functionp callback)
|
||||||
|
(funcall callback exit-code process-buffer info))
|
||||||
|
((consp callback)
|
||||||
|
(apply #'org-async-call callback))
|
||||||
|
((null callback)) ; Do nothing.
|
||||||
|
(t (message "Ignoring invalid `org-async-call' callback: %S" callback))))
|
||||||
|
|
||||||
|
(defvar org-async--monitor-scheduled nil)
|
||||||
|
(defun org-async--monitor (&optional force)
|
||||||
|
"Check each process against their timeouts, and kill any overdue.
|
||||||
|
The only runs when `org-async--monitor-scheduled' is nil, unless FORCE is set.
|
||||||
|
Should any processes still be alive after checking the stack, this will run
|
||||||
|
itself using a timer in `org-async-check-timeout-interval' seconds."
|
||||||
|
(when (or force (null org-async--monitor-scheduled))
|
||||||
|
(dolist (stack-proc org-async--stack)
|
||||||
|
(if (process-live-p (car stack-proc))
|
||||||
|
(let ((timeout (plist-get (cdr stack-proc) :timeout)))
|
||||||
|
(when (and (numberp timeout)
|
||||||
|
(< 0 timeout
|
||||||
|
(- (float-time)
|
||||||
|
(plist-get (cdr stack-proc) :start-time))))
|
||||||
|
(kill-process (car stack-proc))))
|
||||||
|
(org-async--cleanup-process (car stack-proc))))
|
||||||
|
(if org-async--stack
|
||||||
|
(setq org-async--monitor-scheduled
|
||||||
|
(run-at-time org-async-check-timeout-interval
|
||||||
|
nil #'org-async--monitor t))
|
||||||
|
(setq org-async--monitor-scheduled nil))))
|
||||||
|
|
||||||
|
|
||||||
;;; File
|
;;; File
|
||||||
|
|
Loading…
Reference in New Issue