launch-program.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
launch-program.lisp (33643B)
---
1 ;;;; -------------------------------------------------------------------------
2 ;;;; launch-program - semi-portably spawn asynchronous subprocesses
3
4 (uiop/package:define-package :uiop/launch-program
5 (:use :uiop/common-lisp :uiop/package :uiop/utility
6 :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
7 (:export
8 ;;; Escaping the command invocation madness
9 #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
10 #:escape-windows-token #:escape-windows-command
11 #:escape-shell-token #:escape-shell-command
12 #:escape-token #:escape-command
13
14 ;;; launch-program
15 #:launch-program
16 #:close-streams #:process-alive-p #:terminate-process #:wait-process
17 #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid))
18 (in-package :uiop/launch-program)
19
20 ;;;; ----- Escaping strings for the shell -----
21 (with-upgradability ()
22 (defun requires-escaping-p (token &key good-chars bad-chars)
23 "Does this token require escaping, given the specification of
24 either good chars that don't need escaping or bad chars that do need escaping,
25 as either a recognizing function or a sequence of characters."
26 (some
27 (cond
28 ((and good-chars bad-chars)
29 (parameter-error "~S: only one of good-chars and bad-chars can be provided"
30 'requires-escaping-p))
31 ((typep good-chars 'function)
32 (complement good-chars))
33 ((typep bad-chars 'function)
34 bad-chars)
35 ((and good-chars (typep good-chars 'sequence))
36 #'(lambda (c) (not (find c good-chars))))
37 ((and bad-chars (typep bad-chars 'sequence))
38 #'(lambda (c) (find c bad-chars)))
39 (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p)))
40 token))
41
42 (defun escape-token (token &key stream quote good-chars bad-chars escaper)
43 "Call the ESCAPER function on TOKEN string if it needs escaping as per
44 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
45 using STREAM as output (or returning result as a string if NIL)"
46 (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
47 (with-output (stream)
48 (apply escaper token stream (when quote `(:quote ,quote))))
49 (output-string token stream)))
50
51 (defun escape-windows-token-within-double-quotes (x &optional s)
52 "Escape a string token X within double-quotes
53 for use within a MS Windows command-line, outputing to S."
54 (labels ((issue (c) (princ c s))
55 (issue-backslash (n) (loop :repeat n :do (issue #\\))))
56 (loop
57 :initially (issue #\") :finally (issue #\")
58 :with l = (length x) :with i = 0
59 :for i+1 = (1+ i) :while (< i l) :do
60 (case (char x i)
61 ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
62 ((#\\)
63 (let* ((j (and (< i+1 l) (position-if-not
64 #'(lambda (c) (eql c #\\)) x :start i+1)))
65 (n (- (or j l) i)))
66 (cond
67 ((null j)
68 (issue-backslash (* 2 n)) (setf i l))
69 ((and (< j l) (eql (char x j) #\"))
70 (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
71 (t
72 (issue-backslash n) (setf i j)))))
73 (otherwise
74 (issue (char x i)) (setf i i+1))))))
75
76 (defun easy-windows-character-p (x)
77 "Is X an \"easy\" character that does not require quoting by the shell?"
78 (or (alphanumericp x) (find x "+-_.,@:/=")))
79
80 (defun escape-windows-token (token &optional s)
81 "Escape a string TOKEN within double-quotes if needed
82 for use within a MS Windows command-line, outputing to S."
83 (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
84 :escaper 'escape-windows-token-within-double-quotes))
85
86 (defun escape-sh-token-within-double-quotes (x s &key (quote t))
87 "Escape a string TOKEN within double-quotes
88 for use within a POSIX Bourne shell, outputing to S;
89 omit the outer double-quotes if key argument :QUOTE is NIL"
90 (when quote (princ #\" s))
91 (loop :for c :across x :do
92 (when (find c "$`\\\"") (princ #\\ s))
93 (princ c s))
94 (when quote (princ #\" s)))
95
96 (defun easy-sh-character-p (x)
97 "Is X an \"easy\" character that does not require quoting by the shell?"
98 (or (alphanumericp x) (find x "+-_.,%@:/=")))
99
100 (defun escape-sh-token (token &optional s)
101 "Escape a string TOKEN within double-quotes if needed
102 for use within a POSIX Bourne shell, outputing to S."
103 (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
104 :escaper 'escape-sh-token-within-double-quotes))
105
106 (defun escape-shell-token (token &optional s)
107 "Escape a token for the current operating system shell"
108 (os-cond
109 ((os-unix-p) (escape-sh-token token s))
110 ((os-windows-p) (escape-windows-token token s))))
111
112 (defun escape-command (command &optional s
113 (escaper 'escape-shell-token))
114 "Given a COMMAND as a list of tokens, return a string of the
115 spaced, escaped tokens, using ESCAPER to escape."
116 (etypecase command
117 (string (output-string command s))
118 (list (with-output (s)
119 (loop :for first = t :then nil :for token :in command :do
120 (unless first (princ #\space s))
121 (funcall escaper token s))))))
122
123 (defun escape-windows-command (command &optional s)
124 "Escape a list of command-line arguments into a string suitable for parsing
125 by CommandLineToArgv in MS Windows"
126 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
127 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
128 (escape-command command s 'escape-windows-token))
129
130 (defun escape-sh-command (command &optional s)
131 "Escape a list of command-line arguments into a string suitable for parsing
132 by /bin/sh in POSIX"
133 (escape-command command s 'escape-sh-token))
134
135 (defun escape-shell-command (command &optional stream)
136 "Escape a command for the current operating system's shell"
137 (escape-command command stream 'escape-shell-token)))
138
139
140 (with-upgradability ()
141 ;;; Internal helpers for run-program
142 (defun %normalize-io-specifier (specifier &optional role)
143 "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
144 argument to pass to the internal RUN-PROGRAM"
145 (declare (ignorable role))
146 (typecase specifier
147 (null (or #+(or allegro lispworks) (null-device-pathname)))
148 (string (parse-native-namestring specifier))
149 (pathname specifier)
150 (stream specifier)
151 ((eql :stream) :stream)
152 ((eql :interactive)
153 #+(or allegro lispworks) nil
154 #+clisp :terminal
155 #+(or abcl clozure cmucl ecl mkcl sbcl scl) t
156 #-(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp)
157 (not-implemented-error :interactive-output
158 "On this lisp implementation, cannot interpret ~a value of ~a"
159 specifier role))
160 ((eql :output)
161 (cond ((eq role :error-output)
162 #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
163 :output
164 #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
165 (not-implemented-error :error-output-redirect
166 "Can't send ~a to ~a on this lisp implementation."
167 role specifier))
168 (t (parameter-error "~S IO specifier invalid for ~S" specifier role))))
169 (otherwise
170 (parameter-error "Incorrect I/O specifier ~S for ~S"
171 specifier role))))
172
173 (defun %interactivep (input output error-output)
174 (member :interactive (list input output error-output)))
175
176 (defun %signal-to-exit-code (signum)
177 (+ 128 signum))
178
179 (defun %code-to-status (exit-code signal-code)
180 (cond ((null exit-code) :running)
181 ((null signal-code) (values :exited exit-code))
182 (t (values :signaled signal-code))))
183
184 #+mkcl
185 (defun %mkcl-signal-to-number (signal)
186 (require :mk-unix)
187 (symbol-value (find-symbol signal :mk-unix)))
188
189 (defclass process-info ()
190 (;; The process field is highly platform-, implementation-, and
191 ;; even version-dependent.
192 ;; Prior to LispWorks 7, the only information that
193 ;; `sys:run-shell-command` with `:wait nil` was certain to return
194 ;; is a PID (e.g. when all streams are nil), hence we stored it
195 ;; and used `sys:pid-exit-status` to obtain an exit status
196 ;; later. That is still what we do.
197 ;; From LispWorks 7 on, if `sys:run-shell-command` does not
198 ;; return a proper stream, we are instead given a dummy stream.
199 ;; We can thus always store a stream and use
200 ;; `sys:pipe-exit-status` to obtain an exit status later.
201 ;; The advantage of dealing with streams instead of PID is the
202 ;; availability of functions like `sys:pipe-kill-process`.
203 (process :initform nil)
204 (input-stream :initform nil)
205 (output-stream :initform nil)
206 (bidir-stream :initform nil)
207 (error-output-stream :initform nil)
208 ;; For backward-compatibility, to maintain the property (zerop
209 ;; exit-code) <-> success, an exit in response to a signal is
210 ;; encoded as 128+signum.
211 (exit-code :initform nil)
212 ;; If the platform allows it, distinguish exiting with a code
213 ;; >128 from exiting in response to a signal by setting this code
214 (signal-code :initform nil)))
215
216 ;;;---------------------------------------------------------------------------
217 ;;; The following two helper functions take care of handling the IF-EXISTS and
218 ;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
219 ;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
220 ;;; function to treat input and output files unconditionally for reading and
221 ;;; writing.
222 ;;;---------------------------------------------------------------------------
223
224 (defun %handle-if-exists (file if-exists)
225 (when (or (stringp file) (pathnamep file))
226 (ecase if-exists
227 ((:append :supersede :error)
228 (with-open-file (dummy file :direction :output :if-exists if-exists)
229 (declare (ignorable dummy)))))))
230
231 (defun %handle-if-does-not-exist (file if-does-not-exist)
232 (when (or (stringp file) (pathnamep file))
233 (ecase if-does-not-exist
234 ((:create :error)
235 (with-open-file (dummy file :direction :probe
236 :if-does-not-exist if-does-not-exist)
237 (declare (ignorable dummy)))))))
238
239 (defun process-info-error-output (process-info)
240 (slot-value process-info 'error-output-stream))
241 (defun process-info-input (process-info)
242 (or (slot-value process-info 'bidir-stream)
243 (slot-value process-info 'input-stream)))
244 (defun process-info-output (process-info)
245 (or (slot-value process-info 'bidir-stream)
246 (slot-value process-info 'output-stream)))
247
248 (defun process-info-pid (process-info)
249 (let ((process (slot-value process-info 'process)))
250 (declare (ignorable process))
251 #+abcl (symbol-call :sys :process-pid process)
252 #+allegro process
253 #+clozure (ccl:external-process-id process)
254 #+ecl (ext:external-process-pid process)
255 #+(or cmucl scl) (ext:process-pid process)
256 #+lispworks7+ (sys:pipe-pid process)
257 #+(and lispworks (not lispworks7+)) process
258 #+mkcl (mkcl:process-id process)
259 #+sbcl (sb-ext:process-pid process)
260 #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
261 (not-implemented-error 'process-info-pid)))
262
263 (defun %process-status (process-info)
264 (if-let (exit-code (slot-value process-info 'exit-code))
265 (return-from %process-status
266 (if-let (signal-code (slot-value process-info 'signal-code))
267 (values :signaled signal-code)
268 (values :exited exit-code))))
269 #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
270 (not-implemented-error '%process-status)
271 (if-let (process (slot-value process-info 'process))
272 (multiple-value-bind (status code)
273 (progn
274 #+allegro (multiple-value-bind (exit-code pid signal-code)
275 (sys:reap-os-subprocess :pid process :wait nil)
276 (assert pid)
277 (%code-to-status exit-code signal-code))
278 #+clozure (ccl:external-process-status process)
279 #+(or cmucl scl) (let ((status (ext:process-status process)))
280 (if (member status '(:exited :signaled))
281 ;; Calling ext:process-exit-code on
282 ;; processes that are still alive
283 ;; yields an undefined result
284 (values status (ext:process-exit-code process))
285 status))
286 #+ecl (ext:external-process-status process)
287 #+lispworks
288 ;; a signal is only returned on LispWorks 7+
289 (multiple-value-bind (exit-code signal-code)
290 (symbol-call :sys
291 #+lispworks7+ :pipe-exit-status
292 #-lispworks7+ :pid-exit-status
293 process :wait nil)
294 (%code-to-status exit-code signal-code))
295 #+mkcl (let ((status (mk-ext:process-status process)))
296 (if (eq status :exited)
297 ;; Only call mk-ext:process-exit-code when
298 ;; necessary since it leads to another waitpid()
299 (let ((code (mk-ext:process-exit-code process)))
300 (if (stringp code)
301 (values :signaled (%mkcl-signal-to-number code))
302 (values :exited code)))
303 status))
304 #+sbcl (let ((status (sb-ext:process-status process)))
305 (if (eq status :running)
306 :running
307 ;; sb-ext:process-exit-code can also be
308 ;; called for stopped processes to determine
309 ;; the signal that stopped them
310 (values status (sb-ext:process-exit-code process)))))
311 (case status
312 (:exited (setf (slot-value process-info 'exit-code) code))
313 (:signaled (let ((%code (%signal-to-exit-code code)))
314 (setf (slot-value process-info 'exit-code) %code
315 (slot-value process-info 'signal-code) code))))
316 (if code
317 (values status code)
318 status))))
319
320 (defun process-alive-p (process-info)
321 "Check if a process has yet to exit."
322 (unless (slot-value process-info 'exit-code)
323 #+abcl (sys:process-alive-p (slot-value process-info 'process))
324 #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
325 #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
326 #-(or abcl cmucl sbcl scl) (find (%process-status process-info)
327 '(:running :stopped :continued :resumed))))
328
329 (defun wait-process (process-info)
330 "Wait for the process to terminate, if it is still running.
331 Otherwise, return immediately. An exit code (a number) will be
332 returned, with 0 indicating success, and anything else indicating
333 failure. If the process exits after receiving a signal, the exit code
334 will be the sum of 128 and the (positive) numeric signal code. A second
335 value may be returned in this case: the numeric signal code itself.
336 Any asynchronously spawned process requires this function to be run
337 before it is garbage-collected in order to free up resources that
338 might otherwise be irrevocably lost."
339 (if-let (exit-code (slot-value process-info 'exit-code))
340 (if-let (signal-code (slot-value process-info 'signal-code))
341 (values exit-code signal-code)
342 exit-code)
343 (let ((process (slot-value process-info 'process)))
344 #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
345 (not-implemented-error 'wait-process)
346 (when process
347 ;; 1- wait
348 #+clozure (ccl::external-process-wait process)
349 #+(or cmucl scl) (ext:process-wait process)
350 #+sbcl (sb-ext:process-wait process)
351 ;; 2- extract result
352 (multiple-value-bind (exit-code signal-code)
353 (progn
354 #+abcl (sys:process-wait process)
355 #+allegro (multiple-value-bind (exit-code pid signal)
356 (sys:reap-os-subprocess :pid process :wait t)
357 (assert pid)
358 (values exit-code signal))
359 #+clozure (multiple-value-bind (status code)
360 (ccl:external-process-status process)
361 (if (eq status :signaled)
362 (values nil code)
363 code))
364 #+(or cmucl scl) (let ((status (ext:process-status process))
365 (code (ext:process-exit-code process)))
366 (if (eq status :signaled)
367 (values nil code)
368 code))
369 #+ecl (multiple-value-bind (status code)
370 (ext:external-process-wait process t)
371 (if (eq status :signaled)
372 (values nil code)
373 code))
374 #+lispworks (symbol-call :sys
375 #+lispworks7+ :pipe-exit-status
376 #-lispworks7+ :pid-exit-status
377 process :wait t)
378 #+mkcl (let ((code (mkcl:join-process process)))
379 (if (stringp code)
380 (values nil (%mkcl-signal-to-number code))
381 code))
382 #+sbcl (let ((status (sb-ext:process-status process))
383 (code (sb-ext:process-exit-code process)))
384 (if (eq status :signaled)
385 (values nil code)
386 code)))
387 (if signal-code
388 (let ((%exit-code (%signal-to-exit-code signal-code)))
389 (setf (slot-value process-info 'exit-code) %exit-code
390 (slot-value process-info 'signal-code) signal-code)
391 (values %exit-code signal-code))
392 (progn (setf (slot-value process-info 'exit-code) exit-code)
393 exit-code)))))))
394
395 ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
396 ;; do what you expect it to. Sending SIGSTOP to a process spawned
397 ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
398 ;; to run the command (via `sh -c command`) but not the actual
399 ;; command.
400 #+os-unix
401 (defun %posix-send-signal (process-info signal)
402 #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
403 #+clozure (ccl:signal-external-process (slot-value process-info 'process)
404 signal :error-if-exited nil)
405 #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
406 #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
407 #-(or allegro clozure cmucl sbcl scl)
408 (if-let (pid (process-info-pid process-info))
409 (symbol-call :uiop :run-program
410 (format nil "kill -~a ~a" signal pid) :ignore-error-status t)))
411
412 ;;; this function never gets called on Windows, but the compiler cannot tell
413 ;;; that. [2016/09/25:rpg]
414 #+os-windows
415 (defun %posix-send-signal (process-info signal)
416 (declare (ignore process-info signal))
417 (values))
418
419 (defun terminate-process (process-info &key urgent)
420 "Cause the process to exit. To that end, the process may or may
421 not be sent a signal, which it will find harder (or even impossible)
422 to ignore if URGENT is T. On some platforms, it may also be subject to
423 race conditions."
424 (declare (ignorable urgent))
425 #+abcl (sys:process-kill (slot-value process-info 'process))
426 ;; On ECL, this will only work on versions later than 2016-09-06,
427 ;; but we still want to compile on earlier versions, so we use symbol-call
428 #+ecl (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent)
429 #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
430 #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
431 :force urgent)
432 #-(or abcl ecl lispworks7+ mkcl)
433 (os-cond
434 ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
435 ((os-windows-p) (if-let (pid (process-info-pid process-info))
436 (symbol-call :uiop :run-program
437 (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid)
438 :ignore-error-status t)))
439 (t (not-implemented-error 'terminate-process))))
440
441 (defun close-streams (process-info)
442 "Close any stream that the process might own. Needs to be run
443 whenever streams were requested by passing :stream to :input, :output,
444 or :error-output."
445 (dolist (stream
446 (cons (slot-value process-info 'error-output-stream)
447 (if-let (bidir-stream (slot-value process-info 'bidir-stream))
448 (list bidir-stream)
449 (list (slot-value process-info 'input-stream)
450 (slot-value process-info 'output-stream)))))
451 (when stream (close stream))))
452
453 (defun launch-program (command &rest keys
454 &key
455 input (if-input-does-not-exist :error)
456 output (if-output-exists :supersede)
457 error-output (if-error-output-exists :supersede)
458 (element-type #-clozure *default-stream-element-type*
459 #+clozure 'character)
460 (external-format *utf-8-external-format*)
461 directory
462 #+allegro separate-streams
463 &allow-other-keys)
464 "Launch program specified by COMMAND,
465 either a list of strings specifying a program and list of arguments,
466 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
467 Windows) _asynchronously_.
468
469 If OUTPUT is a pathname, a string designating a pathname, or NIL (the
470 default) designating the null device, the file at that path is used as
471 output.
472 If it's :INTERACTIVE, output is inherited from the current process;
473 beware that this may be different from your *STANDARD-OUTPUT*, and
474 under SLIME will be on your *inferior-lisp* buffer. If it's T, output
475 goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new
476 stream will be made available that can be accessed via
477 PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
478 that the underlying lisp implementation knows how to handle.
479
480 IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
481 pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
482 default). The meaning of these values and their effect on the case
483 where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
484 to OPEN with :DIRECTION :OUTPUT.
485
486 ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
487 :OUTPUT means redirecting the error output to the output stream,
488 and :STREAM causes a stream to be made available via
489 PROCESS-INFO-ERROR-OUTPUT.
490
491 IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
492 affects ERROR-OUTPUT rather than OUTPUT.
493
494 INPUT is similar to OUTPUT, except that T designates the
495 *STANDARD-INPUT* and a stream requested through the :STREAM keyword
496 would be available through PROCESS-INFO-INPUT.
497
498 IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
499 or a pathname, can take the values :CREATE and :ERROR (the
500 default). The meaning of these values is analogous to the
501 IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
502
503 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
504 implementation, when applicable, for creation of the output stream.
505
506 LAUNCH-PROGRAM returns a PROCESS-INFO object."
507 #-(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
508 (progn command keys input output error-output directory element-type external-format
509 if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore
510 (not-implemented-error 'launch-program))
511 #+allegro
512 (when (some #'(lambda (stream)
513 (and (streamp stream)
514 (not (file-stream-p stream))))
515 (list input output error-output))
516 (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
517 'launch-program))
518 #+(or abcl clisp lispworks)
519 (when (some #'streamp (list input output error-output))
520 (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
521 'launch-program))
522 #+clisp
523 (unless (eq error-output :interactive)
524 (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
525 'launch-program :error-output :interactive))
526 #+ecl
527 (when (some #'(lambda (stream)
528 (and (streamp stream)
529 (not (file-or-synonym-stream-p stream))))
530 (list input output error-output))
531 (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
532 'launch-program))
533 #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
534 (nest
535 (progn ;; see comments for these functions
536 (%handle-if-does-not-exist input if-input-does-not-exist)
537 (%handle-if-exists output if-output-exists)
538 (%handle-if-exists error-output if-error-output-exists))
539 #+ecl (let ((*standard-input* *stdin*)
540 (*standard-output* *stdout*)
541 (*error-output* *stderr*)))
542 (let ((process-info (make-instance 'process-info))
543 (input (%normalize-io-specifier input :input))
544 (output (%normalize-io-specifier output :output))
545 (error-output (%normalize-io-specifier error-output :error-output))
546 #+(and allegro os-windows) (interactive (%interactivep input output error-output))
547 (command
548 (etypecase command
549 #+os-unix (string `("/bin/sh" "-c" ,command))
550 #+os-unix (list command)
551 #+os-windows
552 (string
553 ;; NB: On other Windows implementations, this is utterly bogus
554 ;; except in the most trivial cases where no quoting is needed.
555 ;; Use at your own risk.
556 #-(or allegro clisp clozure ecl)
557 (nest
558 #+(or ecl sbcl) (unless (find-symbol* :escape-arguments #+ecl :ext #+sbcl :sb-impl nil))
559 (parameter-error "~S doesn't support string commands on Windows on this Lisp"
560 'launch-program command))
561 ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
562 ;; when the command contains spaces or special characters:
563 ;; IIUC, the system will use space as a separator,
564 ;; but the C++ argv-decoding libraries won't, and
565 ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
566 ;; yet neither allegro nor clisp provide access to that argument.
567 #+(or allegro clisp) (strcat "cmd /c " command)
568 ;; On ClozureCL for Windows, we assume you are using
569 ;; r15398 or later in 1.9 or later,
570 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
571 ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304
572 ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
573 #+(or clozure ecl sbcl) (cons "cmd" (strcat "/c " command)))
574 #+os-windows
575 (list
576 #+allegro (escape-windows-command command)
577 #-allegro command)))))
578 #+(or abcl (and allegro os-unix) clozure cmucl ecl mkcl sbcl)
579 (let ((program (car command))
580 #-allegro (arguments (cdr command))))
581 #+(and (or ecl sbcl) os-windows)
582 (multiple-value-bind (arguments escape-arguments)
583 (if (listp arguments)
584 (values arguments t)
585 (values (list arguments) nil)))
586 #-(or allegro mkcl sbcl) (with-current-directory (directory))
587 (multiple-value-bind
588 #+(or abcl clozure cmucl sbcl scl) (process)
589 #+allegro (in-or-io out-or-err err-or-pid pid-or-nil)
590 #+ecl (stream code process)
591 #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil)
592 #+mkcl (stream process code)
593 #.`(apply
594 #+abcl 'sys:run-program
595 #+allegro ,@'('excl:run-shell-command
596 #+os-unix (coerce (cons program command) 'vector)
597 #+os-windows command)
598 #+clozure 'ccl:run-program
599 #+(or cmucl ecl scl) 'ext:run-program
600 #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed
601 #+mkcl 'mk-ext:run-program
602 #+sbcl 'sb-ext:run-program
603 #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments)
604 #+(and (or ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments)
605 :input input :if-input-does-not-exist :error
606 :output output :if-output-exists :append
607 ,(or #+(or allegro lispworks) :error-output :error) error-output
608 ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append
609 :wait nil :element-type element-type :external-format external-format
610 :allow-other-keys t
611 #+allegro ,@`(:directory directory
612 #+os-windows ,@'(:show-window (if interactive nil :hide)))
613 #+lispworks ,@'(:save-exit-status t)
614 #+mkcl ,@'(:directory (native-namestring directory))
615 #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
616 #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys)))))
617 (labels ((prop (key value) (setf (slot-value process-info key) value)))
618 #+allegro
619 (cond
620 (separate-streams
621 (prop 'process pid-or-nil)
622 (when (eq input :stream) (prop 'input-stream in-or-io))
623 (when (eq output :stream) (prop 'output-stream out-or-err))
624 (when (eq error-output :stream) (prop 'error-stream err-or-pid)))
625 (t
626 (prop 'process err-or-pid)
627 (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
628 (0)
629 (1 (prop 'input-stream in-or-io))
630 (2 (prop 'output-stream in-or-io))
631 (3 (prop 'bidir-stream in-or-io)))
632 (when (eq error-output :stream)
633 (prop 'error-stream out-or-err))))
634 #+(or abcl clozure cmucl sbcl scl)
635 (progn
636 (prop 'process process)
637 (when (eq input :stream)
638 (nest
639 (prop 'input-stream)
640 #+abcl (symbol-call :sys :process-input)
641 #+clozure (ccl:external-process-input-stream)
642 #+(or cmucl scl) (ext:process-input)
643 #+sbcl (sb-ext:process-input)
644 process))
645 (when (eq output :stream)
646 (nest
647 (prop 'output-stream)
648 #+abcl (symbol-call :sys :process-output)
649 #+clozure (ccl:external-process-output-stream)
650 #+(or cmucl scl) (ext:process-output)
651 #+sbcl (sb-ext:process-output)
652 process))
653 (when (eq error-output :stream)
654 (nest
655 (prop 'error-output-stream)
656 #+abcl (symbol-call :sys :process-error)
657 #+clozure (ccl:external-process-error-stream)
658 #+(or cmucl scl) (ext:process-error)
659 #+sbcl (sb-ext:process-error)
660 process)))
661 #+(or ecl mkcl)
662 (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
663 code ;; ignore
664 (unless (zerop mode)
665 (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))
666 (prop 'process process))
667 #+lispworks
668 ;; See also the comments on the process-info class
669 (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
670 (cond
671 ((or (plusp mode) (eq error-output :stream))
672 (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil)
673 (when (plusp mode)
674 (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream))
675 io-or-pid))
676 (when (eq error-output :stream)
677 (prop 'error-stream err-or-nil)))
678 ;; Prior to Lispworks 7, this returned (pid); now it
679 ;; returns (io err pid) of which we keep io.
680 (t (prop 'process io-or-pid)))))
681 process-info)))
682