From 6b6aff2ef2cac22057a592974cfd73f59a43d486 Mon Sep 17 00:00:00 2001 From: TEC Date: Sun, 19 Sep 2021 02:41:57 +0800 Subject: [PATCH] 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. --- lisp/org-macs.el | 171 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 171 insertions(+) diff --git a/lisp/org-macs.el b/lisp/org-macs.el index 1254ddb54..3019e817c 100644 --- a/lisp/org-macs.el +++ b/lisp/org-macs.el @@ -368,6 +368,177 @@ If EXCLUDE-TMP is non-nil, ignore temporary buffers." nil)) (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