diff --git a/.local/share/common-lisp/source/ambrevar/all.lisp b/.local/share/common-lisp/source/ambrevar/all.lisp index acc4e6cc..1ef6d508 100644 --- a/.local/share/common-lisp/source/ambrevar/all.lisp +++ b/.local/share/common-lisp/source/ambrevar/all.lisp @@ -42,4 +42,5 @@ #:ambrevar/debug #:ambrevar/guix #:ambrevar/shell - #:ambrevar/syspack)) + #:ambrevar/syspack + #:ambrevar/patches/cmd)) diff --git a/.local/share/common-lisp/source/ambrevar/patches/cmd.lisp b/.local/share/common-lisp/source/ambrevar/patches/cmd.lisp new file mode 100644 index 00000000..0f49bdf2 --- /dev/null +++ b/.local/share/common-lisp/source/ambrevar/patches/cmd.lisp @@ -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))))))