49 lines
1.9 KiB
Common Lisp
49 lines
1.9 KiB
Common Lisp
(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))))))
|