diff --git a/emacs-deferred/deferred.el b/emacs-deferred/deferred.el index 041c90b..84e8cc8 100644 --- a/emacs-deferred/deferred.el +++ b/emacs-deferred/deferred.el @@ -756,6 +756,15 @@ The next deferred object receives stdout and stderr string from the command process." (deferred:process-gen 'start-process-shell-command command args)) +(defun deferred:process-w-stderr (command &rest args) + "A deferred wrapper of `make-process'. Return a deferred +object. The process name and buffer name of the argument of the +`make-process' are generated by this function automatically. The +next deferred object receives a list containing (exit-code stdout +stderr), where stdout and stderr are strings, from the command +process." + (deferred:process-gen 'make-process command args)) + (defun deferred:process-buffer (command &rest args) "A deferred wrapper of `start-process'. Return a deferred object. The process name and buffer name of the argument of the @@ -772,62 +781,115 @@ The next deferred object receives stdout and stderr buffer from the command process." (deferred:process-buffer-gen 'start-process-shell-command command args)) +(defun deferred:process-w-stderr-buffer (command &rest args) + "A deferred wrapper of `make-process'. Return a deferred +object. The process name and buffer name of the argument of the +`make-process' are generated by this function automatically. The +next deferred object receives a list containing (exit-code stdout +stderr), where stdout and stderr are buffers, from the command +process." + (deferred:process-buffer-gen 'make-process command args)) + (defun deferred:process-gen (f command args) "[internal]" (let ((pd (deferred:process-buffer-gen f command args)) d) (setq d (deferred:nextc pd - (lambda (buf) - (prog1 - (with-current-buffer buf (buffer-string)) - (kill-buffer buf))))) + (lambda (output) + (if (eq f 'make-process) + (let ((exit-code (nth 0 output)) + (stdout (nth 1 output)) + (stderr (nth 2 output))) + (prog1 + (list exit-code + (with-current-buffer stdout (buffer-string)) + (with-current-buffer stderr (buffer-string))) + (kill-buffer stdout) + (kill-buffer stderr))) + (prog1 + (with-current-buffer output (buffer-string)) + (kill-buffer output)))))) (setf (deferred-cancel d) (lambda (_x) (deferred:default-cancel d) (deferred:default-cancel pd))) d)) +(defun deferred:run-proc (nd f proc-name buf-name command args) + "[internal]" + (let (proc-buf proc) + (setq proc-buf (get-buffer-create buf-name)) + (setq proc + (if (null (car args)) + (apply f proc-name buf-name command nil) + (apply f proc-name buf-name command args))) + (set-process-sentinel + proc + (lambda (proc event) + (unless (process-live-p proc) + (if (zerop (process-exit-status proc)) + (deferred:post-task nd 'ok proc-buf) + (let ((msg (format "Deferred process exited abnormally:\n command: %s\n exit status: %s %s\n event: %s\n buffer contents: %S" + command + (process-status proc) + (process-exit-status proc) + (string-trim-right event) + (if (buffer-live-p proc-buf) + (with-current-buffer proc-buf + (buffer-string)) + "(unavailable)")))) + (kill-buffer proc-buf) + (deferred:post-task nd 'ng msg)))))) + (setf (deferred-cancel nd) + (lambda (x) (deferred:default-cancel x) + (when proc + (kill-process proc) + (kill-buffer proc-buf)))))) + +(defun deferred:run-proc-w-stderr (nd proc-name buf-name err-buf-name command args) + "[internal]" + (let (proc-buf proc-err-buf proc) + (setq proc-buf (get-buffer-create buf-name) + proc-err-buf (get-buffer-create err-buf-name)) + (setq proc + (make-process + :name proc-name + :buffer buf-name + :command (cons command args) + :sentinel (lambda (proc _event) + (unless (process-live-p proc) + (deferred:post-task nd 'ok + (list (process-exit-status proc) + proc-buf + proc-err-buf)))) + :stderr err-buf-name)) + (setf (deferred-cancel nd) + (lambda (x) (deferred:default-cancel x) + (when proc + (kill-process proc) + (kill-buffer proc-buf) + (kill-buffer proc-err-buf)))))) + (defun deferred:process-buffer-gen (f command args) "[internal]" (let ((d (deferred:next)) (uid (deferred:uid))) (let ((proc-name (format "*deferred:*%s*:%s" command uid)) (buf-name (format " *deferred:*%s*:%s" command uid)) + (err-buf-name (format " *deferred:err:*%s*:%s" command uid)) (pwd default-directory) (env process-environment) (con-type process-connection-type) - (nd (deferred:new)) proc-buf proc) + (nd (deferred:new))) (deferred:nextc d (lambda (_x) - (setq proc-buf (get-buffer-create buf-name)) (condition-case err (let ((default-directory pwd) (process-environment env) (process-connection-type con-type)) - (setq proc - (if (null (car args)) - (apply f proc-name buf-name command nil) - (apply f proc-name buf-name command args))) - (set-process-sentinel - proc - (lambda (proc event) - (unless (process-live-p proc) - (if (zerop (process-exit-status proc)) - (deferred:post-task nd 'ok proc-buf) - (let ((msg (format "Deferred process exited abnormally:\n command: %s\n exit status: %s %s\n event: %s\n buffer contents: %S" - command - (process-status proc) - (process-exit-status proc) - (string-trim-right event) - (if (buffer-live-p proc-buf) - (with-current-buffer proc-buf - (buffer-string)) - "(unavailable)")))) - (kill-buffer proc-buf) - (deferred:post-task nd 'ng msg)))))) - (setf (deferred-cancel nd) - (lambda (x) (deferred:default-cancel x) - (when proc - (kill-process proc) - (kill-buffer proc-buf))))) + (if (eq f 'make-process) + (deferred:run-proc-w-stderr nd + proc-name buf-name err-buf-name command args) + (deferred:run-proc nd + f proc-name buf-name command args))) (error (deferred:post-task nd 'ng err))) nil)) nd)))