run-program.lisp 47.8 KB
Newer Older
1
;;;; -------------------------------------------------------------------------
2
;;;; run-program initially from xcvb-driver.
3

4
(uiop/package:define-package :uiop/run-program
5
  (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
6
7
  (:use :uiop/common-lisp :uiop/package :uiop/utility
   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
8
9
10
11
12
13
  (:export
   ;;; Escaping the command invocation madness
   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
   #:escape-windows-token #:escape-windows-command
   #:escape-token #:escape-command

14
   ;;; run-program
15
   #:slurp-input-stream #:vomit-output-stream
Elias Pipping's avatar
Elias Pipping committed
16
   #:close-streams #:run-program
17
   #:subprocess-error
18
19
   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
   ))
20
(in-package :uiop/run-program)
21
22
23

;;;; ----- Escaping strings for the shell -----

24
25
26
(with-upgradability ()
  (defun requires-escaping-p (token &key good-chars bad-chars)
    "Does this token require escaping, given the specification of
27
28
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."
29
30
31
32
    (some
     (cond
       ((and good-chars bad-chars)
        (error "only one of good-chars and bad-chars can be provided"))
33
       ((typep good-chars 'function)
34
        (complement good-chars))
35
       ((typep bad-chars 'function)
36
37
38
39
40
41
42
43
44
45
        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
46
47
REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
using STREAM as output (or returning result as a string if NIL)"
48
49
50
51
    (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)))
52

53
54
  (defun escape-windows-token-within-double-quotes (x &optional s)
    "Escape a string token X within double-quotes
55
for use within a MS Windows command-line, outputing to S."
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
    (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))))))

78
79
80
81
  (defun easy-windows-character-p (x)
    "Is X an \"easy\" character that does not require quoting by the shell?"
    (or (alphanumericp x) (find x "+-_.,@:/=")))

82
83
  (defun escape-windows-token (token &optional s)
    "Escape a string TOKEN within double-quotes if needed
84
for use within a MS Windows command-line, outputing to S."
85
    (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
86
                        :escaper 'escape-windows-token-within-double-quotes))
87

88
89
  (defun escape-sh-token-within-double-quotes (x s &key (quote t))
    "Escape a string TOKEN within double-quotes
90
91
for use within a POSIX Bourne shell, outputing to S;
omit the outer double-quotes if key argument :QUOTE is NIL"
92
93
94
95
96
    (when quote (princ #\" s))
    (loop :for c :across x :do
      (when (find c "$`\\\"") (princ #\\ s))
      (princ c s))
    (when quote (princ #\" s)))
97

98
  (defun easy-sh-character-p (x)
99
    "Is X an \"easy\" character that does not require quoting by the shell?"
100
    (or (alphanumericp x) (find x "+-_.,%@:/=")))
101

102
103
  (defun escape-sh-token (token &optional s)
    "Escape a string TOKEN within double-quotes if needed
104
for use within a POSIX Bourne shell, outputing to S."
105
    (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
106
107
108
                        :escaper 'escape-sh-token-within-double-quotes))

  (defun escape-shell-token (token &optional s)
109
    "Escape a token for the current operating system shell"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
110
    (os-cond
111
112
113
114
115
116
      ((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
117
spaced, escaped tokens, using ESCAPER to escape."
118
119
120
121
122
123
124
125
126
    (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
127
128
129
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
130
    (escape-command command s 'escape-windows-token))
131

132
133
  (defun escape-sh-command (command &optional s)
    "Escape a list of command-line arguments into a string suitable for parsing
134
by /bin/sh in POSIX"
135
    (escape-command command s 'escape-sh-token))
136

137
138
139
  (defun escape-shell-command (command &optional stream)
    "Escape a command for the current operating system's shell"
    (escape-command command stream 'escape-shell-token)))
140
141


142
;;;; Slurping a stream, typically the output of another program
143
(with-upgradability ()
144
  (defun call-stream-processor (fun processor stream)
145
146
147
148
    "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
a PROCESSOR specification which is either an atom or a list specifying
a processor an keyword arguments, call the specified processor with
the given STREAM as input"
149
150
151
152
    (if (consp processor)
        (apply fun (first processor) stream (rest processor))
        (funcall fun processor stream)))

153
  (defgeneric slurp-input-stream (processor input-stream &key)
154
155
156
157
158
159
160
161
    (:documentation
     "SLURP-INPUT-STREAM is a generic function with two positional arguments
PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
the contents of the INPUT-STREAM and processes them according to a method
specified by PROCESSOR.

Built-in methods include the following:
* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
162
* if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the
163
164
  INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
    \(APPLY x <stream> y\)
165
* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
166
167
168
169
170
171
172
  per copy-stream-to-stream, with appropriate keyword arguments.
* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
  are returned as a string, as per SLURP-STREAM-STRING.
* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
173
* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
174
175

Programmers are encouraged to define their own methods for this generic function."))
176

177
  #-genera
178
  (defmethod slurp-input-stream ((function function) input-stream &key)
179
180
    (funcall function input-stream))

181
  (defmethod slurp-input-stream ((list cons) input-stream &key)
182
    (apply (first list) input-stream (rest list)))
183

184
  #-genera
185
  (defmethod slurp-input-stream ((output-stream stream) input-stream
186
                                 &key linewise prefix (element-type 'character) buffer-size)
187
188
189
190
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

191
192
  (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
    (slurp-stream-string stream :stripped stripped))
193

194
195
  (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
    (slurp-stream-string stream :stripped stripped))
196

197
  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
198
199
    (slurp-stream-lines stream :count count))

200
  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
201
202
    (slurp-stream-line stream :at at))

203
  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
204
205
    (slurp-stream-forms stream :count count))

206
  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
207
208
    (slurp-stream-form stream :at at))

209
210
211
  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    (apply 'slurp-input-stream *standard-output* stream keys))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
212
  (defmethod slurp-input-stream ((x null) (stream t) &key)
213
214
    nil)

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
  (defmethod slurp-input-stream ((pathname pathname) input
                                 &key
                                   (element-type *default-stream-element-type*)
                                   (external-format *utf-8-external-format*)
                                   (if-exists :rename-and-delete)
                                   (if-does-not-exist :create)
                                   buffer-size
                                   linewise)
    (with-output-file (output pathname
                              :element-type element-type
                              :external-format external-format
                              :if-exists if-exists
                              :if-does-not-exist if-does-not-exist)
      (copy-stream-to-stream
       input output
       :element-type element-type :buffer-size buffer-size :linewise linewise)))

232
  (defmethod slurp-input-stream (x stream
233
                                 &key linewise prefix (element-type 'character) buffer-size)
234
235
    (declare (ignorable stream linewise prefix element-type buffer-size))
    (cond
236
      #+genera
237
      ((functionp x) (funcall x stream))
238
      #+genera
239
240
      ((output-stream-p x)
       (copy-stream-to-stream
241
        stream x
242
243
244
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
       (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
245

246

247
(with-upgradability ()
248
  (defgeneric vomit-output-stream (processor output-stream &key)
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
    (:documentation
     "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.

Built-in methods include the following:
* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
* if PROCESSOR is a list, its first element should be a function.
  It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
  That is (x . y) will be treated as \(APPLY x <stream> y\)
* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
  per copy-stream-to-stream, with appropriate keyword arguments.
* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.

Programmers are encouraged to define their own methods for this generic function."))

266
  #-genera
267
  (defmethod vomit-output-stream ((function function) output-stream &key)
268
269
    (funcall function output-stream))

270
  (defmethod vomit-output-stream ((list cons) output-stream &key)
271
272
    (apply (first list) output-stream (rest list)))

273
  #-genera
274
  (defmethod vomit-output-stream ((input-stream stream) output-stream
275
                                 &key linewise prefix (element-type 'character) buffer-size)
276
277
278
279
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

280
  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
281
282
283
284
285
286
287
288
    (princ x stream)
    (when fresh-line (fresh-line stream))
    (when terpri (terpri stream))
    (values))

  (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    (apply 'vomit-output-stream *standard-input* stream keys))

289
  (defmethod vomit-output-stream ((x null) (stream t) &key)
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
    (values))

  (defmethod vomit-output-stream ((pathname pathname) input
                                 &key
                                   (element-type *default-stream-element-type*)
                                   (external-format *utf-8-external-format*)
                                   (if-exists :rename-and-delete)
                                   (if-does-not-exist :create)
                                   buffer-size
                                   linewise)
    (with-output-file (output pathname
                              :element-type element-type
                              :external-format external-format
                              :if-exists if-exists
                              :if-does-not-exist if-does-not-exist)
      (copy-stream-to-stream
       input output
       :element-type element-type :buffer-size buffer-size :linewise linewise)))

  (defmethod vomit-output-stream (x stream
310
                                 &key linewise prefix (element-type 'character) buffer-size)
311
312
    (declare (ignorable stream linewise prefix element-type buffer-size))
    (cond
313
      #+genera
314
      ((functionp x) (funcall x stream))
315
      #+genera
316
317
318
319
320
      ((input-stream-p x)
       (copy-stream-to-stream
        x stream
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
321
       (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
322
323


324
325
326
;;;; ----- Running an external program -----
;;; Simple variant of run-program with no input, and capturing output
;;; On some implementations, may output to a temporary file...
327
328
329
330
331
332
(with-upgradability ()
  (define-condition subprocess-error (error)
    ((code :initform nil :initarg :code :reader subprocess-error-code)
     (command :initform nil :initarg :command :reader subprocess-error-command)
     (process :initform nil :initarg :process :reader subprocess-error-process))
    (:report (lambda (condition stream)
333
               (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
334
335
336
337
                       (subprocess-error-process condition)
                       (subprocess-error-command condition)
                       (subprocess-error-code condition)))))

338
339
340
341
342
343
344
345
346
  ;;; find CMD.exe on windows
  (defun %cmd-shell-pathname ()
    (os-cond
     ((os-windows-p)
      (strcat (native-namestring (getenv-absolute-directory "WINDIR"))
              "System32\\cmd.exe"))
     (t
      (error "CMD.EXE is not the command shell for this OS."))))

347
348
  ;;; Internal helpers for run-program
  (defun %normalize-command (command)
349
350
    "Given a COMMAND as a list or string, transform it in a format suitable
for the implementation's underlying run-program function"
351
352
353
354
355
356
357
358
359
360
361
    (etypecase command
      #+os-unix (string `("/bin/sh" "-c" ,command))
      #+os-unix (list command)
      #+os-windows
      (string
       ;; NB: We do NOT add cmd /c here. You might want to.
       #+(or allegro clisp) 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
       #+clozure (cons "cmd" (strcat "/c " command))
Elias Pipping's avatar
Elias Pipping committed
362
       #+mkcl (list "cmd" "/c" command)
363
       #+sbcl (list (%cmd-shell-pathname) "/c" command)
364
365
366
       ;; 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.
367
       #-(or allegro clisp clozure mkcl sbcl) (list "cmd" "/c" command))
368
369
370
371
372
373
      #+os-windows
      (list
       #+allegro (escape-windows-command command)
       #-allegro command)))

  (defun %active-io-specifier-p (specifier)
374
375
376
    "Determines whether a run-program I/O specifier requires Lisp-side processing
via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
or whether it's already taken care of by the implementation's underlying run-program."
377
    (not (typep specifier '(or null string pathname (member :interactive :output)
378
                            #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
379
                            #+lispworks file-stream)))) ;; not a type!? comm:socket-stream
380
381

  (defun %normalize-io-specifier (specifier &optional role)
382
383
    "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent
argument to pass to the internal RUN-PROGRAM"
384
385
386
    (declare (ignorable role))
    (etypecase specifier
      (null (or #+(or allegro lispworks) (null-device-pathname)))
387
      (string (parse-native-namestring specifier))
388
      (pathname specifier)
389
390
391
392
393
      (stream specifier)
      ((eql :stream) :stream)
      ((eql :interactive)
       #+allegro nil
       #+clisp :terminal
394
395
       #+(or clozure cmucl ecl mkcl sbcl scl) t)
      #+(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
396
397
398
399
400
      ((eql :output)
       (if (eq role :error-output)
           :output
           (error "Wrong specifier ~S for role ~S" specifier role)))))

401
402
403
404
405
  (defun %normalize-if-exists (action)
    (ecase action
      (:supersede #+clisp :overwrite #-clisp action)
      ((:append :error) action)))

406
407
408
409
410
411
412
413
414
415
  (defun %interactivep (input output error-output)
    (member :interactive (list input output error-output)))

  #+clisp
  (defun clisp-exit-code (raw-exit-code)
    (typecase raw-exit-code
      (null 0) ; no error
      (integer raw-exit-code) ; negative: signal
      (t -1)))

Elias Pipping's avatar
Elias Pipping committed
416
417
418
419
420
421
422
423
  (defclass process-info ()
    ((process :initform nil)
     (input-stream :initform nil)
     (output-stream :initform nil)
     (bidir-stream :initform nil)
     (error-output-stream :initform nil)
     (exit-code :initform nil)))

424
425
426
  (defun %run-program (command
                       &rest keys
                       &key input (if-input-does-not-exist :error)
427
428
                         output (if-output-exists :supersede)
                         error-output (if-error-output-exists :supersede)
429
430
431
432
433
434
435
                         directory wait
                         #+allegro separate-streams
                         &allow-other-keys)
    "A portable abstraction of a low-level call to the implementation's run-program or equivalent.
It spawns a subprocess that runs the specified COMMAND (a list of program and arguments).
INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
to be normalized by %NORMALIZE-IO-SPECIFIER.
Elias Pipping's avatar
Elias Pipping committed
436
It returns a process-info object."
437
    ;; NB: these implementations have Unix vs Windows set at compile-time.
438
    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
439
    #-(or allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
Elias Pipping's avatar
Elias Pipping committed
440
441
    (progn command keys input output error-output directory wait ;; ignore
           (not-implemented-error '%run-program))
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
    #-(or cmucl ecl mkcl sbcl)
    (when (and wait (member :stream (list input output error-output)))
      (parameter-error "~S: I/O parameters cannot be ~S when ~S is ~S on this lisp"
                       '%run-program :stream :wait t))
    #+allegro
    (when (some #'(lambda (stream)
                    (and (streamp stream)
                         (not (file-stream-p stream))))
                (list input output error-output))
      (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
                       '%run-program))
    #+(or clisp lispworks)
    (when (some #'streamp (list input output error-output))
      (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
                       '%run-program))
    #+clisp
    (unless (eq error-output :interactive)
      (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
                       '%run-program :error-output :interactive))
    #+clisp
    (when (or (stringp input) (pathnamep input))
      (unless (file-exists-p input)
        (parameter-error "~S: Files passed as arguments to ~S need to exist on this lisp"
                         '%run-program :input)))
    #+ecl
    (when (some #'(lambda (stream)
                    (and (streamp stream)
                         (not (file-or-synonym-stream-p stream))))
                (list input output error-output))
      (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
                       '%run-program))
473
    #+(or allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
474
    (let* ((%command (%normalize-command command))
475
           (%if-output-exists (%normalize-if-exists if-output-exists))
476
477
478
           (%input (%normalize-io-specifier input :input))
           (%output (%normalize-io-specifier output :output))
           (%error-output (%normalize-io-specifier error-output :error-output))
479
           #+(and allegro os-windows)
480
481
           (interactive (%interactivep input output error-output))
           (process*
482
483
             (nest
              #-(or allegro mkcl sbcl) (with-current-directory (directory))
484
              #+(or allegro clisp ecl lispworks mkcl) (multiple-value-list)
485
              (apply
486
487
488
               #+allegro 'excl:run-shell-command
               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
               #+(and allegro os-windows) %command
489
               #+clisp
490
491
492
493
494
495
               (etypecase %command
                 #+os-windows
                 (string (lambda (&rest keys) (apply 'ext:run-shell-command %command keys)))
                 (list (lambda (&rest keys)
                         (apply 'ext:run-program (car %command) :arguments (cdr %command) keys))))
               #+clozure 'ccl:run-program
496
               #+(or cmucl ecl scl) 'ext:run-program
497
498
499
500
501
               #+lispworks 'system:run-shell-command
               #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path
               #+mkcl 'mk-ext:run-program
               #+sbcl 'sb-ext:run-program
               (append
502
                #+(or clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
503
504
505
506
                `(:input ,%input :output ,%output :wait ,wait :allow-other-keys t)
                #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error
                            ,%error-output)
                #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
507
                #+clisp `(:if-output-exists ,%if-output-exists)
508
                #+(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
509
                `(:if-input-does-not-exist ,if-input-does-not-exist
510
                  :if-output-exists ,%if-output-exists
511
512
                  #-(or allegro lispworks) :if-error-exists
                  #+(or allegro lispworks) :if-error-output-exists
513
514
                  ,if-error-output-exists)
                #+lispworks `(:save-exit-status t)
Elias Pipping's avatar
Elias Pipping committed
515
                #+mkcl `(:directory ,(native-namestring directory))
516
                #+sbcl `(:search t)
517
518
                #-sbcl keys
                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
Elias Pipping's avatar
Elias Pipping committed
519
           (process-info (make-instance 'process-info)))
520
      #+clisp (declare (ignore %error-output))
Elias Pipping's avatar
Elias Pipping committed
521
522
      (flet ((prop (key value)
               (setf (slot-value process-info key) value)))
523
524
        #+allegro
        (cond
Elias Pipping's avatar
Elias Pipping committed
525
          (wait (prop 'exit-code (first process*)))
526
527
          (separate-streams
           (destructuring-bind (in out err pid) process*
Elias Pipping's avatar
Elias Pipping committed
528
529
530
531
             (prop 'process pid)
             (when (eq input :stream) (prop 'input-stream in))
             (when (eq output :stream) (prop 'output-stream out))
             (when (eq error-output :stream) (prop 'error-stream err))))
532
          (t
Elias Pipping's avatar
Elias Pipping committed
533
           (prop 'process (third process*))
534
535
536
           (let ((x (first process*)))
             (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
               (0)
Elias Pipping's avatar
Elias Pipping committed
537
538
539
               (1 (prop 'input-stream x))
               (2 (prop 'output-stream x))
               (3 (prop 'bidir-stream x))))
540
           (when (eq error-output :stream)
Elias Pipping's avatar
Elias Pipping committed
541
             (prop 'error-stream (second process*)))))
542
543
        #+clisp
        (cond
Elias Pipping's avatar
Elias Pipping committed
544
          (wait (prop 'exit-code (clisp-exit-code (first process*))))
545
546
547
          (t
           (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
             (0)
Elias Pipping's avatar
Elias Pipping committed
548
549
550
551
552
             (1 (prop 'input-stream (first process*)))
             (2 (prop 'output-stream (first process*)))
             (3 (prop 'bidir-stream (pop process*))
              (prop 'input-stream (pop process*))
              (prop 'output-stream (pop process*))))))
553
        #+(or clozure cmucl sbcl scl)
554
        (progn
Elias Pipping's avatar
Elias Pipping committed
555
          (prop 'process process*)
556
          (when (eq input :stream)
Elias Pipping's avatar
Elias Pipping committed
557
            (prop 'input-stream
558
                  #+clozure (ccl:external-process-input-stream process*)
559
                  #+(or cmucl scl) (ext:process-input process*)
560
561
                  #+sbcl (sb-ext:process-input process*)))
          (when (eq output :stream)
Elias Pipping's avatar
Elias Pipping committed
562
            (prop 'output-stream
563
                  #+clozure (ccl:external-process-output-stream process*)
564
                  #+(or cmucl scl) (ext:process-output process*)
565
                  #+sbcl (sb-ext:process-output process*)))
566
          (when (eq error-output :stream)
Elias Pipping's avatar
Elias Pipping committed
567
            (prop 'error-output-stream
568
                  #+clozure (ccl:external-process-error-stream process*)
569
                  #+(or cmucl scl) (ext:process-error process*)
570
                  #+sbcl (sb-ext:process-error process*))))
571
572
        #+(or ecl mkcl)
        (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
573
574
575
          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
            (cond
              ((zerop mode))
Elias Pipping's avatar
Elias Pipping committed
576
577
578
579
              ((null process*) (prop 'exit-code -1))
              (t (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))))
          (when code (prop 'exit-code code))
          (when process (prop 'process process)))
580
581
        #+lispworks
        (if wait
582
            (prop 'exit-code (or (second process*) (first process*)))
583
            (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
584
585
586
587
588
589
590
591
592
593
594
595
596
              (if (or (plusp mode) (eq error-output :stream))
                  (destructuring-bind (io err pid) process*
                    #+lispworks7+ (declare (ignore pid))
                    (prop 'process #+lispworks7+ io #-lispworks7+ pid)
                    (when (plusp mode)
                      (prop (ecase mode
                              (1 'input-stream)
                              (2 'output-stream)
                              (3 'bidir-stream)) io))
                    (when (eq error-output :stream)
                      (prop 'error-stream err)))
                  ;; lispworks6 returns (pid), lispworks7 returns (io,err,pid).
                  (prop 'process (first process*)))))
Elias Pipping's avatar
Elias Pipping committed
597
        process-info)))
598

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
599
  (defun %process-info-pid (process-info)
Elias Pipping's avatar
Elias Pipping committed
600
    (let ((process (slot-value process-info 'process)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
601
      (declare (ignorable process))
602
      #+allegro process
603
      #+clozure (ccl:external-process-id process)
604
      #+ecl (ext:external-process-pid process)
605
      #+(or cmucl scl) (ext:process-pid process)
606
607
      #+lispworks7+ (sys:pipe-pid process)
      #+(and lispworks (not lispworks7+)) process
608
      #+mkcl (mkcl:process-id process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
609
      #+sbcl (sb-ext:process-pid process)
610
      #-(or allegro clozure cmucl ecl mkcl lispworks sbcl scl)
Elias Pipping's avatar
Elias Pipping committed
611
      (not-implemented-error '%process-info-pid)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
612

613
  (defun %wait-process-result (process-info)
Elias Pipping's avatar
Elias Pipping committed
614
615
    (or (slot-value process-info 'exit-code)
        (let ((process (slot-value process-info 'process)))
616
          #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
Elias Pipping's avatar
Elias Pipping committed
617
          (not-implemented-error '%wait-process-result)
618
619
          (when process
            ;; 1- wait
620
            #+clozure (ccl::external-process-wait process)
621
            #+(or cmucl scl) (ext:process-wait process)
622
623
            #+sbcl (sb-ext:process-wait process)
            ;; 2- extract result
624
625
626
627
628
629
630
            (let ((exit-code
                   #+allegro (multiple-value-bind (exit-code pid signal)
                                 (sys:reap-os-subprocess :pid process :wait t)
                               (assert pid)
                               (or signal exit-code))
                   #+clozure (nth-value 1 (ccl:external-process-status process))
                   #+(or cmucl scl) (ext:process-exit-code process)
631
                   #+ecl (nth-value 1 (ext:external-process-wait process t))
632
633
634
635
636
637
638
                   #+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 t)
                     (or signal exit-code))
639
640
641
642
                   #+mkcl (mkcl:join-process process)
                   #+sbcl (sb-ext:process-exit-code process)))
              (setf (slot-value process-info 'exit-code) exit-code)
              exit-code)))))
643
644
645
646
647
648
649
650

  (defun %check-result (exit-code &key command process ignore-error-status)
    (unless ignore-error-status
      (unless (eql exit-code 0)
        (cerror "IGNORE-ERROR-STATUS"
                'subprocess-error :command command :code exit-code :process process)))
    exit-code)

Elias Pipping's avatar
Elias Pipping committed
651
652
653
654
655
656
657
658
659
660
661
662
  (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))))

663
664
665
666
667
668
669
670
  (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
                                &key element-type external-format &allow-other-keys)
    ;; handle redirection for run-program and system
    ;; SPEC is the specification for the subprocess's input or output or error-output
    ;; TVAL is the value used if the spec is T
    ;; GF is the generic function to call to handle arbitrary values of SPEC
    ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
    ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
671
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
672
673
674
675
676
677
678
    ;; FUN is a function of the new reduced spec and an activity function to call with a stream
    ;; when the subprocess is active and communicating through that stream.
    ;; ACTIVEP is a boolean true if we will get to run code while the process is running
    ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
    ;; RETURNER is a function called with the value of the activity.
    ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
    (declare (ignorable stream-easy-p))
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
    (let* ((actual-spec (if (eq spec t) tval spec))
           (activity-spec (if (eq actual-spec :output)
                              (ecase direction
                                ((:input :output)
                                 (error "~S not allowed as a ~S ~S spec"
                                        :output 'run-program direction))
                                ((:error-output)
                                 nil))
                              actual-spec)))
      (labels ((activity (stream)
                 (call-function returner (call-stream-processor gf activity-spec stream)))
               (easy-case ()
                 (funcall fun actual-spec nil))
               (hard-case ()
                 (if activep
                     (funcall fun :stream #'activity)
695
                     (with-temporary-file (:pathname tmp)
696
697
                       (ecase direction
                         (:input
698
699
700
701
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
702
703
                          (funcall fun tmp nil))
                         ((:output :error-output)
704
705
706
707
708
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
709
710
711
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
712
          #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
713
714
715
716
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748

  (defmacro place-setter (place)
    (when place
      (let ((value (gensym)))
        `#'(lambda (,value) (setf ,place ,value)))))

  (defmacro with-program-input (((reduced-input-var
                                  &optional (input-activity-var (gensym) iavp))
                                 input-form &key setf stream-easy-p active keys) &body body)
    `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
            #'(lambda (,reduced-input-var ,input-activity-var)
                ,@(unless iavp `((declare (ignore ,input-activity-var))))
                ,@body)
            :input ,input-form ,active (place-setter ,setf) ,keys))

  (defmacro with-program-output (((reduced-output-var
                                  &optional (output-activity-var (gensym) oavp))
                                  output-form &key setf stream-easy-p active keys) &body body)
    `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
            #'(lambda (,reduced-output-var ,output-activity-var)
                ,@(unless oavp `((declare (ignore ,output-activity-var))))
                ,@body)
            :output ,output-form ,active (place-setter ,setf) ,keys))

  (defmacro with-program-error-output (((reduced-error-output-var
                                         &optional (error-output-activity-var (gensym) eoavp))
                                        error-output-form &key setf stream-easy-p active keys)
                                       &body body)
    `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
            #'(lambda (,reduced-error-output-var ,error-output-activity-var)
                ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
                ,@body)
749
            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
750
751
752

  (defun %use-run-program (command &rest keys
                           &key input output error-output ignore-error-status &allow-other-keys)
753
    ;; helper for RUN-PROGRAM when using %run-program
754
    #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl)
755
756
    (progn
      command keys input output error-output ignore-error-status ;; ignore
Elias Pipping's avatar
Elias Pipping committed
757
      (not-implemented-error '%use-run-program))
758
759
760
    (assert (not (member :stream (list input output error-output))))
    (let* ((active-input-p (%active-io-specifier-p input))
           (active-output-p (%active-io-specifier-p output))
761
           (active-error-output-p (%active-io-specifier-p error-output))
762
763
764
765
766
767
768
           (activity
             (cond
               (active-output-p :output)
               (active-input-p :input)
               (active-error-output-p :error-output)
               (t nil)))
           (wait (not activity))
769
           output-result error-output-result exit-code process-info)
770
771
772
773
      (with-program-output ((reduced-output output-activity)
                            output :keys keys :setf output-result
                            :stream-easy-p t :active (eq activity :output))
        (with-program-error-output ((reduced-error-output error-output-activity)
774
                                    error-output :keys keys :setf error-output-result
775
776
777
778
                                    :stream-easy-p t :active (eq activity :error-output))
          (with-program-input ((reduced-input input-activity)
                               input :keys keys
                               :stream-easy-p t :active (eq activity :input))
779
            (setf process-info
Elias Pipping's avatar
Elias Pipping committed
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
                  (apply '%run-program command
                         :wait wait :input reduced-input :output reduced-output
                         :error-output (if (eq error-output :output) :output reduced-error-output)
                         keys))
            (labels ((get-stream (stream-name &optional fallbackp)
                       (or (slot-value process-info stream-name)
                           (when fallbackp
                             (slot-value process-info 'bidir-stream))))
                     (run-activity (activity stream-name &optional fallbackp)
                       (if-let (stream (get-stream stream-name fallbackp))
                         (funcall activity stream)
                         (error 'subprocess-error
                                :code `(:missing ,stream-name)
                                :command command :process process-info))))
              (unwind-protect
                   (ecase activity
                     ((nil))
                     (:input (run-activity input-activity 'input-stream t))
                     (:output (run-activity output-activity 'output-stream t))
                     (:error-output (run-activity error-output-activity 'error-output-stream)))
Elias Pipping's avatar
Elias Pipping committed
800
                (close-streams process-info)
Elias Pipping's avatar
Elias Pipping committed
801
                (setf exit-code (%wait-process-result process-info)))))))
802
803
804
      (%check-result exit-code
                     :command command :process process-info
                     :ignore-error-status ignore-error-status)
805
806
      (values output-result error-output-result exit-code)))

807
  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
808
    (etypecase command
809
810
811
      (string
       (os-cond
        ((os-windows-p)
812
813
814
         #+(or allegro clisp)
         (strcat (%cmd-shell-pathname) " /c " command)
         #-(or allegro clisp) command)
815
        (t command)))
816
      (list (escape-shell-command
817
818
             (os-cond
              ((os-unix-p) (cons "exec" command))
819
820
821
822
              ((os-windows-p)
               #+(or allegro sbcl clisp)
               (cons (%cmd-shell-pathname) (cons "/c" command))
               #-(or allegro sbcl clisp) command)
823
              (t command))))))
824

825
  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
826
827
828
829
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
830
                       (string (parse-native-namestring spec))
831
832
                       (pathname spec)
                       ((eql :output)
833
                        (assert (equal operator " 2>"))
834
835
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
836
                 (list operator " "
837
                       (escape-shell-token (native-namestring pathname)))))))
838
839
      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
             (normalized (%normalize-system-command command))
840
             (directory (or directory #+(or abcl xcl) (getcwd)))
841
842
843
844
845
             (chdir (when directory
                      (let ((dir-arg (escape-shell-token (native-namestring directory))))
                        (os-cond
                         ((os-unix-p) `("cd " ,dir-arg " ; "))
                         ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
846
        (reduce/strcat
847
848
         (os-cond
          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
849
          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
850

851
852
853
  (defun %system (command &rest keys
                  &key input output error-output directory &allow-other-keys)
    "A portable abstraction of a low-level call to libc's system()."
854
    (declare (ignorable input output error-output directory keys))
855
    #+(or allegro clozure cmucl (and lispworks os-unix) sbcl scl)
856
    (%wait-process-result
857
     (apply '%run-program (%normalize-system-command command) :wait t keys))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
858
    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
859
860
861
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
862
863
864
865
866
      #+clisp
      (%wait-process-result
       (apply '%run-program %command :wait t
              :input :interactive :output :interactive :error-output :interactive keys))
      #-(or clisp (and lispworks os-windows))
867
      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
868
        #+abcl (ext:run-shell-command %command)
869
        #+cormanlisp (win32:system %command)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
870
        #+(or clasp ecl) (let ((*standard-input* *stdin*)
871
872
873
                    (*standard-output* *stdout*)
                    (*error-output* *stderr*))
                (ext:system %command))
874
        #+gcl (system:system %command)
Elias Pipping's avatar
Elias Pipping committed
875
        #+genera (not-implemented-error '%system)
876
        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
877
        #+mkcl (mkcl:system %command)
878
        #+xcl (system:%run-shell-command %command))))
879
880
881

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
882
    ;; helper for RUN-PROGRAM when using %system
883
884
885
886
887
888
    (let (output-result error-output-result exit-code)
      (with-program-output ((reduced-output)
                            output :keys keys :setf output-result)
        (with-program-error-output ((reduced-error-output)
                                    error-output :keys keys :setf error-output-result)
          (with-program-input ((reduced-input) input :keys keys)
889
890
891
892
893
894
            (setf exit-code (apply '%system command
                                   :input reduced-input :output reduced-output
                                   :error-output reduced-error-output keys)))))
      (%check-result exit-code
                     :command command
                     :ignore-error-status ignore-error-status)
895
896
897
      (values output-result error-output-result exit-code)))

  (defun run-program (command &rest keys
898
                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
899
                         (input nil inputp) (if-input-does-not-exist :error)
900
901
                         output (if-output-exists :supersede)
                         (error-output nil error-output-p) (if-error-output-exists :supersede)
902
903
904
                         (element-type #-clozure *default-stream-element-type* #+clozure 'character)
                         (external-format *utf-8-external-format*)
                      &allow-other-keys)
905
    "Run program specified by COMMAND,
906
either a list of strings specifying a program and list of arguments,
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
907
908
909
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
_synchronously_ process its output as specified and return the processing results
when the program and its output processing are complete.
910

911
Always call a shell (rather than directly execute the command when possible)
912
913
if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
specified to be NIL.
914

915
Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
916
917
unless IGNORE-ERROR-STATUS is specified.

918
919
If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device,
the file at that path is used as output.
920
921
922
923
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.
924
Otherwise, OUTPUT should be a value that is a suitable first argument to
925
SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
926
927
In this case, RUN-PROGRAM will create a temporary stream for the program output;
the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
928
929
930
931
using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
The primary value resulting from that call (or NIL if no call was needed)
will be the first value returned by RUN-PROGRAM.
E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
932
933
And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
stripped of any ending newline.
934
935
936

ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
937
938
Also :OUTPUT means redirecting the error output to the output stream,
in which case NIL is returned.
939
940
941
942

INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
no value is returned, and T designates the *STANDARD-INPUT*.

943
944
Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
to your Lisp implementation, when applicable, for creation of the output stream.
945
946

One and only one of the stream slurping or vomiting may or may not happen
947
948
949
950
951
in parallel in parallel with the subprocess,
depending on options and implementation,
and with priority being given to output processing.
Other streams are completely produced or consumed
before or after the subprocess is spawned, using temporary files.
952
953
954
955
956
957
958

RUN-PROGRAM returns 3 values:
0- the result of the OUTPUT slurping if any, or NIL
1- the result of the ERROR-OUTPUT slurping if any, or NIL
2- either 0 if the subprocess exited with success status,
or an indication of failure via the EXIT-CODE of the process"
    (declare (ignorable ignore-error-status))
959
    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
Elias Pipping's avatar
Elias Pipping committed
960
    (not-implemented-error 'run-program)
961
962
963
964
    ;; per doc string, set FORCE-SHELL to T if we get command as a string.  But
    ;; don't override user's specified preference. [2015/06/29:rpg]
    (when (stringp command)
      (unless force-shell-suppliedp
965
        #-(and sbcl os-windows) ;; force-shell t isn't working properly on windows as of sbcl 1.2.16
966
        (setf force-shell t)))
967
968
    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
      (apply (if (or force-shell
969
                     #+(or clasp clisp) (or (not ignore-error-status) t)
970
                     #+clisp (member error-output '(:interactive :output))
971
972
                     ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
                     #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
973
                               (lexicographic<= '< ver '(16 0 1)))
974
                     #+(and lispworks os-unix) (%interactivep input output error-output)
975
                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
976
977
978
979
980
981
982
983
                 '%use-system '%use-run-program)
             command
             :input (default input inputp output)
             :error-output (default error-output error-output-p output)
             :if-input-does-not-exist if-input-does-not-exist
             :if-output-exists if-output-exists
             :if-error-output-exists if-error-output-exists
             :element-type element-type :external-format external-format
984
             keys))))