Commit ff089b82 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Split launch-program.lisp off of run-program.lisp

parent c5a0c97d
......@@ -78,7 +78,7 @@ SCL ?= scl
XCL ?= xcl
header_lisp := header.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
defsystem_lisp := upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp
all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
......
......@@ -4,7 +4,7 @@
set here=%~dp0
set header_lisp=header.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp
set defsystem_lisp=upgrade.lisp + cache.lisp + component.lisp + system.lisp + find-system.lisp + find-component.lisp + operation.lisp + action.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + output-translations.lisp + source-registry.lisp + package-inferred-system.lisp + backward-interface.lisp + backward-internals.lisp + interface.lisp + user.lisp + footer.lisp
%~d0
......
......@@ -5,7 +5,7 @@
here="$(dirname $0)"
header_lisp="header.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp"
defsystem_lisp="upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp"
all () {
......
......@@ -542,18 +542,21 @@
(new-test-suite "%process-status / terminate-process")
(defun process-status (process-info)
(uiop/launch-program::%process-status process-info))
(define-test
":exited (we slept; repeated query)"
(let* ((process-info (launch-program "./sleeper.sh 12 1"))
(status (uiop/run-program::%process-status process-info)))
(status (process-status process-info)))
(handle-result "running?" (equal :running status))
(sleep 2)
(multiple-value-bind (status exit-code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "exited?" (equal :exited status))
(handle-result "proper exit status?" (equal 12 exit-code)))
(multiple-value-bind (status exit-code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "exited? (no. 2)" (equal :exited status))
(handle-result "proper exit status? (no. 2)" (equal 12 exit-code)))
(wait-process process-info)))
......@@ -565,14 +568,14 @@
(let* ((process-info (launch-program "./killer.sh")))
(sleep 1)
(multiple-value-bind (status code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "exited or signaled?"
(member status '(:exited :signaled)))
(handle-result "signal/exit code as expected?"
(or (and (eq status :exited) (eql code 143))
(and (eq status :signaled) (eql code 15)))))
(multiple-value-bind (status code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "exited or signaled? (no. 2)"
(member status '(:exited :signaled)))
(handle-result "signal/exit code as expected? (no. 2)"
......@@ -585,11 +588,11 @@
(let* ((process-info (launch-program "./killercontainer.sh")))
(sleep 1)
(multiple-value-bind (status code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "exited?" (eq status :exited))
(handle-result "proper exit status?" (eql code (+ 128 15))))
(multiple-value-bind (status code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "exited (no. 2)?" (eq status :exited))
(handle-result "proper exit status? (no. 2)?" (eql code (+ 128 15))))
(wait-process process-info)))
......@@ -599,16 +602,16 @@
#+(and lispworks (not lispworks7+))
(skip-test "Known to fail")
(let* ((process-info (launch-program "./sleeper.sh 12 2"))
(status (uiop/run-program::%process-status process-info)))
(status (process-status process-info)))
(handle-result "running?" (equal :running status))
(my-terminate-process process-info :urgent t)
(sleep 1)
(multiple-value-bind (status code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "signaled?" (eq status :signaled))
(handle-result "signal as expected?" (member code '(9 15))))
(multiple-value-bind (status code)
(uiop/run-program::%process-status process-info)
(process-status process-info)
(handle-result "signaled (no. 2)?" (eq status :signaled))
(handle-result "signal as expected (no. 2)?" (member code '(9 15))))
(wait-process process-info)))
......
......@@ -12,7 +12,8 @@
(:use-reexport
:uiop/package :uiop/utility
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
:uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
:uiop/launch-program :uiop/run-program
:uiop/lisp-build :uiop/configuration :uiop/backward-driver))
;; Provide both lowercase and uppercase, to satisfy more people.
(provide "uiop") (provide "UIOP")
;;;; -------------------------------------------------------------------------
;;;; launch-program - semi-portably spawn asynchronous subprocesses
(uiop/package:define-package :uiop/launch-program
(:use :uiop/common-lisp :uiop/package :uiop/utility
:uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
(:export
;;; Escaping the command invocation madness
#:easy-sh-character-p #:escape-sh-token #:escape-sh-command
#:escape-windows-token #:escape-windows-command
#:escape-shell-token #:escape-shell-command
#:escape-token #:escape-command
;;; launch-program
#:launch-program
#:close-streams #:process-alive-p #:terminate-process #:wait-process
#:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid))
(in-package :uiop/launch-program)
;;;; ----- Escaping strings for the shell -----
(with-upgradability ()
(defun requires-escaping-p (token &key good-chars bad-chars)
"Does this token require escaping, given the specification of
either good chars that don't need escaping or bad chars that do need escaping,
as either a recognizing function or a sequence of characters."
(some
(cond
((and good-chars bad-chars)
(error "only one of good-chars and bad-chars can be provided"))
((typep good-chars 'function)
(complement good-chars))
((typep bad-chars 'function)
bad-chars)
((and good-chars (typep good-chars 'sequence))
#'(lambda (c) (not (find c good-chars))))
((and bad-chars (typep bad-chars 'sequence))
#'(lambda (c) (find c bad-chars)))
(t (error "requires-escaping-p: no good-char criterion")))
token))
(defun escape-token (token &key stream quote good-chars bad-chars escaper)
"Call the ESCAPER function on TOKEN string if it needs escaping as per
REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
using STREAM as output (or returning result as a string if NIL)"
(if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
(with-output (stream)
(apply escaper token stream (when quote `(:quote ,quote))))
(output-string token stream)))
(defun escape-windows-token-within-double-quotes (x &optional s)
"Escape a string token X within double-quotes
for use within a MS Windows command-line, outputing to S."
(labels ((issue (c) (princ c s))
(issue-backslash (n) (loop :repeat n :do (issue #\\))))
(loop
:initially (issue #\") :finally (issue #\")
:with l = (length x) :with i = 0
:for i+1 = (1+ i) :while (< i l) :do
(case (char x i)
((#\") (issue-backslash 1) (issue #\") (setf i i+1))
((#\\)
(let* ((j (and (< i+1 l) (position-if-not
#'(lambda (c) (eql c #\\)) x :start i+1)))
(n (- (or j l) i)))
(cond
((null j)
(issue-backslash (* 2 n)) (setf i l))
((and (< j l) (eql (char x j) #\"))
(issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
(t
(issue-backslash n) (setf i j)))))
(otherwise
(issue (char x i)) (setf i i+1))))))
(defun easy-windows-character-p (x)
"Is X an \"easy\" character that does not require quoting by the shell?"
(or (alphanumericp x) (find x "+-_.,@:/=")))
(defun escape-windows-token (token &optional s)
"Escape a string TOKEN within double-quotes if needed
for use within a MS Windows command-line, outputing to S."
(escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
:escaper 'escape-windows-token-within-double-quotes))
(defun escape-sh-token-within-double-quotes (x s &key (quote t))
"Escape a string TOKEN within double-quotes
for use within a POSIX Bourne shell, outputing to S;
omit the outer double-quotes if key argument :QUOTE is NIL"
(when quote (princ #\" s))
(loop :for c :across x :do
(when (find c "$`\\\"") (princ #\\ s))
(princ c s))
(when quote (princ #\" s)))
(defun easy-sh-character-p (x)
"Is X an \"easy\" character that does not require quoting by the shell?"
(or (alphanumericp x) (find x "+-_.,%@:/=")))
(defun escape-sh-token (token &optional s)
"Escape a string TOKEN within double-quotes if needed
for use within a POSIX Bourne shell, outputing to S."
(escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
:escaper 'escape-sh-token-within-double-quotes))
(defun escape-shell-token (token &optional s)
"Escape a token for the current operating system shell"
(os-cond
((os-unix-p) (escape-sh-token token s))
((os-windows-p) (escape-windows-token token s))))
(defun escape-command (command &optional s
(escaper 'escape-shell-token))
"Given a COMMAND as a list of tokens, return a string of the
spaced, escaped tokens, using ESCAPER to escape."
(etypecase command
(string (output-string command s))
(list (with-output (s)
(loop :for first = t :then nil :for token :in command :do
(unless first (princ #\space s))
(funcall escaper token s))))))
(defun escape-windows-command (command &optional s)
"Escape a list of command-line arguments into a string suitable for parsing
by CommandLineToArgv in MS Windows"
;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
(escape-command command s 'escape-windows-token))
(defun escape-sh-command (command &optional s)
"Escape a list of command-line arguments into a string suitable for parsing
by /bin/sh in POSIX"
(escape-command command s 'escape-sh-token))
(defun escape-shell-command (command &optional stream)
"Escape a command for the current operating system's shell"
(escape-command command stream 'escape-shell-token)))
(with-upgradability ()
;;; Internal helpers for run-program
(defun %normalize-command (command)
"Given a COMMAND as a list or string, transform it in a format suitable
for the implementation's underlying run-program function"
(etypecase command
#+os-unix (string `("/bin/sh" "-c" ,command))
#+os-unix (list command)
#+os-windows
(string
;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
;; when the command contains spaces or special characters:
;; IIUC, the system will use space as a separator, but the argv-decoding libraries won't,
;; and you're supposed to use an extra argument to CreateProcess to bridge the gap,
;; but neither allegro nor clisp provide access to that argument.
#+(or allegro clisp) (strcat "cmd /c " command)
;; On ClozureCL for Windows, we assume you are using
;; r15398 or later in 1.9 or later,
;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
;; On SBCL, we assume the patch from https://bugs.launchpad.net/sbcl/+bug/1503496
#+(or clozure sbcl) (cons "cmd" (strcat "/c " command))
;; NB: On other Windows implementations, this is utterly bogus
;; except in the most trivial cases where no quoting is needed.
;; Use at your own risk.
#-(or allegro clisp clozure sbcl)
(parameter-error "~S doesn't support string commands on Windows on this lisp: ~S" '%normalize-command command))
#+os-windows
(list
#+allegro (escape-windows-command command)
#-allegro command)))
(defun %normalize-io-specifier (specifier &optional role)
"Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
argument to pass to the internal RUN-PROGRAM"
(declare (ignorable role))
(typecase specifier
(null (or #+(or allegro lispworks) (null-device-pathname)))
(string (parse-native-namestring specifier))
(pathname specifier)
(stream specifier)
((eql :stream) :stream)
((eql :interactive)
#+(or allegro lispworks) nil
#+clisp :terminal
#+(or abcl clozure cmucl ecl mkcl sbcl scl) t
#-(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp)
(not-implemented-error :interactive-output
"On this lisp implementation, cannot interpret ~a value of ~a"
specifier role))
((eql :output)
(cond ((eq role :error-output)
#+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
:output
#-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
(not-implemented-error :error-output-redirect
"Can't send ~a to ~a on this lisp implementation."
role specifier))
(t (parameter-error "~S IO specifier invalid for ~S" specifier role))))
(otherwise
(parameter-error "Incorrect I/O specifier ~S for ~S"
specifier role))))
(defun %interactivep (input output error-output)
(member :interactive (list input output error-output)))
(defun %signal-to-exit-code (signum)
(+ 128 signum))
#+mkcl
(defun %mkcl-signal-to-number (signal)
(require :mk-unix)
(symbol-value (find-symbol signal :mk-unix)))
(defclass process-info ()
((process :initform nil)
(input-stream :initform nil)
(output-stream :initform nil)
(bidir-stream :initform nil)
(error-output-stream :initform nil)
;; For backward-compatibility, to maintain the property (zerop
;; exit-code) <-> success, an exit in response to a signal is
;; encoded as 128+signum.
(exit-code :initform nil)
;; If the platform allows it, distinguish exiting with a code
;; >128 from exiting in response to a signal by setting this code
(signal-code :initform nil)))
;;;---------------------------------------------------------------------------
;;; The following two helper functions take care of handling the IF-EXISTS and
;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
;;; function to treat input and output files unconditionally for reading and
;;; writing.
;;;---------------------------------------------------------------------------
(defun %handle-if-exists (file if-exists)
(when (or (stringp file) (pathnamep file))
(ecase if-exists
((:append :supersede :error)
(with-open-file (dummy file :direction :output :if-exists if-exists)
(declare (ignorable dummy)))))))
(defun %handle-if-does-not-exist (file if-does-not-exist)
(when (or (stringp file) (pathnamep file))
(ecase if-does-not-exist
((:create :error)
(with-open-file (dummy file :direction :probe
:if-does-not-exist if-does-not-exist)
(declare (ignorable dummy)))))))
(defun process-info-error-output (process-info)
(slot-value process-info 'error-output-stream))
(defun process-info-input (process-info)
(or (slot-value process-info 'bidir-stream)
(slot-value process-info 'input-stream)))
(defun process-info-output (process-info)
(or (slot-value process-info 'bidir-stream)
(slot-value process-info 'output-stream)))
(defun process-info-pid (process-info)
(let ((process (slot-value process-info 'process)))
(declare (ignorable process))
#+abcl (symbol-call :sys :process-pid process)
#+allegro process
#+clozure (ccl:external-process-id process)
#+ecl (ext:external-process-pid process)
#+(or cmucl scl) (ext:process-pid process)
#+lispworks7+ (sys:pipe-pid process)
#+(and lispworks (not lispworks7+)) process
#+mkcl (mkcl:process-id process)
#+sbcl (sb-ext:process-pid process)
#-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
(not-implemented-error 'process-info-pid)))
(defun %process-status (process-info)
(if-let (exit-code (slot-value process-info 'exit-code))
(return-from %process-status
(if-let (signal-code (slot-value process-info 'signal-code))
(values :signaled signal-code)
(values :exited exit-code))))
#-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
(not-implemented-error '%process-status)
(if-let (process (slot-value process-info 'process))
(multiple-value-bind (status code)
(progn
#+allegro (multiple-value-bind (exit-code pid signal)
(sys:reap-os-subprocess :pid process :wait nil)
(assert pid)
(cond ((null exit-code) :running)
((null signal) (values :exited exit-code))
(t (values :signaled signal))))
#+clozure (ccl:external-process-status process)
#+(or cmucl scl) (let ((status (ext:process-status process)))
(values status (if (member status '(:exited :signaled))
(ext:process-exit-code process))))
#+ecl (ext:external-process-status process)
#+lispworks
;; a signal is only returned on LispWorks 7+
(multiple-value-bind (exit-code signal)
(funcall #+lispworks7+ #'sys:pipe-exit-status
#-lispworks7+ #'sys:pid-exit-status
process :wait nil)
(cond ((null exit-code) :running)
((null signal) (values :exited exit-code))
(t (values :signaled signal))))
#+mkcl (let ((status (mk-ext:process-status process))
(code (mk-ext:process-exit-code process)))
(if (stringp code)
(values :signaled (%mkcl-signal-to-number code))
(values status code)))
#+sbcl (let ((status (sb-ext:process-status process)))
(values status (if (member status '(:exited :signaled))
(sb-ext:process-exit-code process)))))
(case status
(:exited (setf (slot-value process-info 'exit-code) code))
(:signaled (let ((%code (%signal-to-exit-code code)))
(setf (slot-value process-info 'exit-code) %code
(slot-value process-info 'signal-code) code))))
(values status code))))
(defun process-alive-p (process-info)
"Check if a process has yet to exit."
(unless (slot-value process-info 'exit-code)
#+abcl (sys:process-alive-p (slot-value process-info 'process))
#+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
#+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
#-(or abcl cmucl sbcl scl) (member (%process-status process-info)
'(:running :sleeping))))
(defun wait-process (process-info)
"Wait for the process to terminate, if it is still running.
Otherwise, return immediately. An exit code (a number) will be
returned, with 0 indicating success, and anything else indicating
failure. If the process exits after receiving a signal, the exit code
will be the sum of 128 and the (positive) numeric signal code. A second
value may be returned in this case: the numeric signal code itself.
Any asynchronously spawned process requires this function to be run
before it is garbage-collected in order to free up resources that
might otherwise be irrevocably lost."
(if-let (exit-code (slot-value process-info 'exit-code))
(if-let (signal-code (slot-value process-info 'signal-code))
(values exit-code signal-code)
exit-code)
(let ((process (slot-value process-info 'process)))
#-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
(not-implemented-error 'wait-process)
(when process
;; 1- wait
#+clozure (ccl::external-process-wait process)
#+(or cmucl scl) (ext:process-wait process)
#+sbcl (sb-ext:process-wait process)
;; 2- extract result
(multiple-value-bind (exit-code signal-code)
(progn
#+abcl (sys:process-wait process)
#+allegro (multiple-value-bind (exit-code pid signal)
(sys:reap-os-subprocess :pid process :wait t)
(assert pid)
(values exit-code signal))
#+clozure (multiple-value-bind (status code)
(ccl:external-process-status process)
(if (eq status :signaled)
(values nil code)
code))
#+(or cmucl scl) (let ((status (ext:process-status process))
(code (ext:process-exit-code process)))
(if (eq status :signaled)
(values nil code)
code))
#+ecl (multiple-value-bind (status code)
(ext:external-process-wait process t)
(if (eq status :signaled)
(values nil code)
code))
#+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
#-lispworks7+ #'sys:pid-exit-status
process :wait t)
#+mkcl (let ((code (mkcl:join-process process)))
(if (stringp code)
(values nil (%mkcl-signal-to-number code))
code))
#+sbcl (let ((status (sb-ext:process-status process))
(code (sb-ext:process-exit-code process)))
(if (eq status :signaled)
(values nil code)
code)))
(if signal-code
(let ((%exit-code (%signal-to-exit-code signal-code)))
(setf (slot-value process-info 'exit-code) %exit-code
(slot-value process-info 'signal-code) signal-code)
(values %exit-code signal-code))
(progn (setf (slot-value process-info 'exit-code) exit-code)
exit-code)))))))
;; WARNING: For signals other than SIGTERM and SIGKILL this may not
;; do what you expect it to. Sending SIGSTOP to a process spawned
;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
;; to run the command (via `sh -c command`) but not the actual
;; command.
#+os-unix
(defun %posix-send-signal (process-info signal)
#+allegro (excl.osi:kill (slot-value process-info 'process) signal)
#+clozure (ccl:signal-external-process (slot-value process-info 'process)
signal :error-if-exited nil)
#+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
#+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
#-(or allegro clozure cmucl sbcl scl)
(if-let (pid (process-info-pid process-info))
(run-program (format nil "kill -~a ~a" signal pid)
:ignore-error-status t)))
;;; this function never gets called on Windows, but the compiler cannot tell
;;; that. [2016/09/25:rpg]
#+os-windows
(defun %posix-send-signal (process-info signal)
(declare (ignore process-info signal))
(values))
(defun terminate-process (process-info &key urgent)
"Cause the process to exit. To that end, the process may or may
not be sent a signal, which it will find harder (or even impossible)
to ignore if URGENT is T. On some platforms, it may also be subject to
race conditions."
(declare (ignorable urgent))
#+abcl (sys:process-kill (slot-value process-info 'process))
;; On ECL, this will only work on versions later than 2016-09-06,
;; but we still want to compile on earlier versions, so we use symbol-call
#+ecl (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent)
#+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
#+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
:force urgent)
#-(or abcl ecl lispworks7+ mkcl)
(os-cond
((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
((os-windows-p) (if-let (pid (process-info-pid process-info))
(symbol-call :uiop :run-program
(format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid)
:ignore-error-status t)))
(t (not-implemented-error 'terminate-process))))
(defun close-streams (process-info)
"Close any stream that the process might own. Needs to be run
whenever streams were requested by passing :stream to :input, :output,
or :error-output."
(dolist (stream
(cons (slot-value process-info 'error-output-stream)
(if-let (bidir-stream (slot-value process-info 'bidir-stream))
(list bidir-stream)
(list (slot-value process-info 'input-stream)
(slot-value process-info 'output-stream)))))
(when stream (close stream))))
(defun launch-program (command &rest keys
&key
input (if-input-does-not-exist :error)
output (if-output-exists :supersede)
error-output (if-error-output-exists :supersede)
(element-type #-clozure *default-stream-element-type*
#+clozure 'character)
(external-format *utf-8-external-format*)
directory
#+allegro separate-streams
&allow-other-keys)
"Launch program specified by COMMAND,
either a list of strings specifying a program and list of arguments,
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
Windows) _asynchronously_.
If OUTPUT is a pathname, a string designating a pathname, or NIL (the
default) designating the null device, the file at that path is used as
output.
If it's :INTERACTIVE, output is inherited from the current process;
beware that this may be different from your *STANDARD-OUTPUT*, and
under SLIME will be on your *inferior-lisp* buffer. If it's T, output
goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new
stream will be made available that can be accessed via
PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
that the underlying lisp implementation knows how to handle.
IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
default). The meaning of these values and their effect on the case
where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
to OPEN with :DIRECTION :OUTPUT.
ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
:OUTPUT means redirecting the error output to the output stream,
and :STREAM causes a stream to be made available via
PROCESS-INFO-ERROR-OUTPUT.
IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
affects ERROR-OUTPUT rather than OUTPUT.