launch-program.lisp - clic - Clic is an command line interactive client for gop… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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-outpu… | |
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 esc… | |
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 b… | |
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-escapi… | |
40 token)) | |
41 | |
42 (defun escape-token (token &key stream quote good-chars bad-chars esca… | |
43 "Call the ESCAPER function on TOKEN string if it needs escaping as p… | |
44 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOK… | |
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… | |
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 :sta… | |
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+… | |
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 she… | |
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… | |
84 :escaper 'escape-windows-token-within-double-quo… | |
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 she… | |
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-chara… | |
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 … | |
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 … | |
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 impl… | |
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 clis… | |
157 (not-implemented-error :interactive-output | |
158 "On this lisp implementation, cannot inter… | |
159 specifier role)) | |
160 ((eql :output) | |
161 (cond ((eq role :error-output) | |
162 #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl s… | |
163 :output | |
164 #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl s… | |
165 (not-implemented-error :error-output-redirect | |
166 "Can't send ~a to ~a on this lisp i… | |
167 role specifier)) | |
168 (t (parameter-error "~S IO specifier invalid for ~S" specif… | |
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-EXIS… | |
218 ;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they pro… | |
219 ;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master | |
220 ;;; function to treat input and output files unconditionally for reading… | |
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-ex… | |
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… | |
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… | |
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 proces… | |
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 'pr… | |
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 :r… | |
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… | |
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 proce… | |
365 (code (ext:process-exit-code proc… | |
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-co… | |
391 (values %exit-code signal-code)) | |
392 (progn (setf (slot-value process-info 'exit-code) exit-c… | |
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 'pro… | |
404 signal :error-if-exited nil) | |
405 #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process… | |
406 #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signa… | |
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-s… | |
411 | |
412 ;;; this function never gets called on Windows, but the compiler canno… | |
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 symbo… | |
428 #+ecl (symbol-call :ext :terminate-process (slot-value process-info … | |
429 #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'proce… | |
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… | |
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 'bidi… | |
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 :superse… | |
458 (element-type #-clozure *default-stream-eleme… | |
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 sb… | |
508 (progn command keys input output error-output directory element-type… | |
509 if-input-does-not-exist if-output-exists if-error-output-exis… | |
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 … | |
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 … | |
521 'launch-program)) | |
522 #+clisp | |
523 (unless (eq error-output :interactive) | |
524 (parameter-error "~S: The only admissible value for ~S is ~S on th… | |
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 … | |
532 'launch-program)) | |
533 #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sb… | |
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-ou… | |
546 #+(and allegro os-windows) (interactive (%interactivep input … | |
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 … | |
554 ;; except in the most trivial cases where no quoting is n… | |
555 ;; Use at your own risk. | |
556 #-(or allegro clisp clozure ecl) | |
557 (nest | |
558 #+(or ecl sbcl) (unless (find-symbol* :escape-arguments … | |
559 (parameter-error "~S doesn't support string commands on … | |
560 'launch-program command)) | |
561 ;; NB: We add cmd /c here. Behavior without going through… | |
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 CreateProc… | |
566 ;; yet neither allegro nor clisp provide access to that a… | |
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/t… | |
571 ;; On ECL, commit 2040629 https://gitlab.com/embeddable-c… | |
572 ;; On SBCL, we assume the patch from fcae0fd (to be part … | |
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) 'vecto… | |
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" ,@… | |
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… | |
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-out… | |
608 ,(or #+(or allegro lispworks) :if-error-output-exists :if-err… | |
609 :wait nil :element-type element-type :external-format externa… | |
610 :allow-other-keys t | |
611 #+allegro ,@`(:directory directory | |
612 #+os-windows ,@'(:show-window (if interactive n… | |
613 #+lispworks ,@'(:save-exit-status t) | |
614 #+mkcl ,@'(:directory (native-namestring directory)) | |
615 #-sbcl keys ;; on SBCL, don't pass :directory nil but remove … | |
616 #+sbcl ,@'(:search t (if directory keys (remove-plist-key :di… | |
617 (labels ((prop (key value) (setf (slot-value process-info key) valu… | |
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) … | |
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… | |
663 code ;; ignore | |
664 (unless (zerop mode) | |
665 (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bid… | |
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… | |
670 (cond | |
671 ((or (plusp mode) (eq error-output :stream)) | |
672 (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-… | |
673 (when (plusp mode) | |
674 (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 … | |
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 |