ambrevar: Patch cmd to kill child processes cleanly.
parent
ffa4c799f7
commit
6e868d529b
|
@ -42,4 +42,5 @@
|
|||
#:ambrevar/debug
|
||||
#:ambrevar/guix
|
||||
#:ambrevar/shell
|
||||
#:ambrevar/syspack))
|
||||
#:ambrevar/syspack
|
||||
#:ambrevar/patches/cmd))
|
||||
|
|
|
@ -0,0 +1,48 @@
|
|||
(uiop:define-package ambrevar/patches/cmd
|
||||
(:use #:common-lisp))
|
||||
|
||||
(in-package cmd)
|
||||
|
||||
;; See https://github.com/ruricolist/cmd/issues/5.
|
||||
(defun await (proc &key ignore-error-status tokens)
|
||||
"Wait for PROC to finish."
|
||||
(nest
|
||||
(let ((out (uiop:process-info-output proc))
|
||||
(err (uiop:process-info-error-output proc))))
|
||||
(handler-bind ((serious-condition
|
||||
;; Flush output on error.
|
||||
(lambda (e) (declare (ignore e))
|
||||
(finish-output out)
|
||||
(finish-output err)))))
|
||||
(let ((abnormal? t)))
|
||||
(unwind-protect
|
||||
(multiple-value-prog1
|
||||
(let ((status (uiop:wait-process proc)))
|
||||
(cond ((zerop status)
|
||||
status)
|
||||
(ignore-error-status
|
||||
status)
|
||||
(t
|
||||
(cerror "IGNORE-ERROR-STATUS"
|
||||
'uiop:subprocess-error
|
||||
:command tokens
|
||||
:code status
|
||||
:process proc)
|
||||
status)))
|
||||
(setf abnormal? nil))
|
||||
(when abnormal?
|
||||
;; PATCH:
|
||||
(labels ((child-pids (pid)
|
||||
(let ((pids
|
||||
(mapcar #'parse-integer
|
||||
(ignore-errors
|
||||
(tokens
|
||||
(uiop:run-program `("pgrep" "-P" ,(write-to-string pid))
|
||||
:output '(:string :stripped t)))))))
|
||||
(append (mappend #'child-pids pids)
|
||||
pids))))
|
||||
(mapc (lambda (pid)
|
||||
;; TODO: Use Osicat?
|
||||
(uiop:run-program `("kill" "-TERM" ,(write-to-string pid)) :ignore-error-status t))
|
||||
(child-pids (uiop:process-info-pid proc)))
|
||||
(uiop:terminate-process proc))))))
|
Loading…
Reference in New Issue