run-program.lisp 29.9 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
  (:use :uiop/common-lisp :uiop/package :uiop/utility
7
   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program)
8
  (:export
9
   #:run-program
10
   #:slurp-input-stream #:vomit-output-stream
11
   #:subprocess-error
12
13
14
15
   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process)
  (:import-from :uiop/launch-program
   #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep
   #:input-stream #:output-stream #:error-output-stream))
16
(in-package :uiop/run-program)
17

18
;;;; Slurping a stream, typically the output of another program
19
(with-upgradability ()
20
  (defun call-stream-processor (fun processor stream)
21
22
23
24
    "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"
25
26
27
28
    (if (consp processor)
        (apply fun (first processor) stream (rest processor))
        (funcall fun processor stream)))

29
  (defgeneric slurp-input-stream (processor input-stream &key)
30
31
32
33
34
35
36
37
    (: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
38
* if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the
39
40
  INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
    \(APPLY x <stream> y\)
41
* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
42
43
44
45
46
47
48
  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.
49
* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
50
51

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

53
  #-genera
54
  (defmethod slurp-input-stream ((function function) input-stream &key)
55
56
    (funcall function input-stream))

57
  (defmethod slurp-input-stream ((list cons) input-stream &key)
58
    (apply (first list) input-stream (rest list)))
59

60
  #-genera
61
  (defmethod slurp-input-stream ((output-stream stream) input-stream
62
                                 &key linewise prefix (element-type 'character) buffer-size)
63
64
65
66
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

67
68
  (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
    (slurp-stream-string stream :stripped stripped))
69

70
71
  (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
    (slurp-stream-string stream :stripped stripped))
72

73
  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
74
75
    (slurp-stream-lines stream :count count))

76
  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
77
78
    (slurp-stream-line stream :at at))

79
  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
80
81
    (slurp-stream-forms stream :count count))

82
  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
83
84
    (slurp-stream-form stream :at at))

85
86
87
  (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
88
  (defmethod slurp-input-stream ((x null) (stream t) &key)
89
90
    nil)

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
  (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)))

108
  (defmethod slurp-input-stream (x stream
109
                                 &key linewise prefix (element-type 'character) buffer-size)
110
111
    (declare (ignorable stream linewise prefix element-type buffer-size))
    (cond
112
      #+genera
113
      ((functionp x) (funcall x stream))
114
      #+genera
115
116
      ((output-stream-p x)
       (copy-stream-to-stream
117
        stream x
118
119
120
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
       (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
121

122
;;;; Vomiting a stream, typically into the input of another program.
123
(with-upgradability ()
124
  (defgeneric vomit-output-stream (processor output-stream &key)
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    (: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."))

142
  #-genera
143
  (defmethod vomit-output-stream ((function function) output-stream &key)
144
145
    (funcall function output-stream))

146
  (defmethod vomit-output-stream ((list cons) output-stream &key)
147
148
    (apply (first list) output-stream (rest list)))

149
  #-genera
150
  (defmethod vomit-output-stream ((input-stream stream) output-stream
151
                                 &key linewise prefix (element-type 'character) buffer-size)
152
153
154
155
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

156
  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
157
158
159
160
161
162
163
164
    (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))

165
  (defmethod vomit-output-stream ((x null) (stream t) &key)
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
    (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
186
                                 &key linewise prefix (element-type 'character) buffer-size)
187
188
    (declare (ignorable stream linewise prefix element-type buffer-size))
    (cond
189
      #+genera
190
      ((functionp x) (funcall x stream))
191
      #+genera
192
193
194
195
196
      ((input-stream-p x)
       (copy-stream-to-stream
        x stream
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
197
       (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
198
199


200
;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
201
202
203
204
205
206
(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)
207
               (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
208
209
210
211
                       (subprocess-error-process condition)
                       (subprocess-error-command condition)
                       (subprocess-error-code condition)))))

212
213
214
215
216
217
  (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)
218
219

  (defun %active-io-specifier-p (specifier)
220
221
222
    "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."
223
    (not (typep specifier '(or null string pathname (member :interactive :output)
224
                            #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
Elias Pipping's avatar
Elias Pipping committed
225
                            #+lispworks file-stream))))
226

227
228
229
230
  (defun %run-program (command &rest keys &key &allow-other-keys)
    "DEPRECATED. Use LAUNCH-PROGRAM instead."
    (apply 'launch-program command keys))

231
  (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
232
233
234
                                &key
                                  (element-type #-clozure *default-stream-element-type* #+clozure 'character)
                                  (external-format *utf-8-external-format*) &allow-other-keys)
235
236
237
238
239
240
    ;; 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)
241
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
242
243
244
245
246
247
248
    ;; 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))
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
    (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)
265
                     (with-temporary-file (:pathname tmp)
266
267
                       (ecase direction
                         (:input
268
269
270
271
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
272
273
                          (funcall fun tmp nil))
                         ((:output :error-output)
274
275
276
277
278
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
279
280
281
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
282
          #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
283
284
285
286
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318

  (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)
319
            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
320

321
  (defun %use-launch-program (command &rest keys
322
                           &key input output error-output ignore-error-status &allow-other-keys)
323
    ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
Elias Pipping's avatar
Elias Pipping committed
324
    #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
325
326
    (progn
      command keys input output error-output ignore-error-status ;; ignore
327
      (not-implemented-error '%use-launch-program))
328
329
330
    (when (member :stream (list input output error-output))
      (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
                       'run-program :stream))
331
332
    (let* ((active-input-p (%active-io-specifier-p input))
           (active-output-p (%active-io-specifier-p output))
333
           (active-error-output-p (%active-io-specifier-p error-output))
334
335
336
337
338
339
           (activity
             (cond
               (active-output-p :output)
               (active-input-p :input)
               (active-error-output-p :error-output)
               (t nil)))
340
           output-result error-output-result exit-code process-info)
341
342
343
344
      (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)
345
                                    error-output :keys keys :setf error-output-result
346
347
348
349
                                    :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))
350
            (setf process-info
351
                  (apply 'launch-program command
352
                         :input reduced-input :output reduced-output
Elias Pipping's avatar
Elias Pipping committed
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
                         :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
371
                (close-streams process-info)
372
                (setf exit-code (wait-process process-info)))))))
373
374
375
      (%check-result exit-code
                     :command command :process process-info
                     :ignore-error-status ignore-error-status)
376
377
      (values output-result error-output-result exit-code)))

378
  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
379
    (etypecase command
380
381
382
      (string
       (os-cond
        ((os-windows-p)
383
         #+(or allegro clisp ecl)
Elias Pipping's avatar
Elias Pipping committed
384
         (strcat "cmd" " /c " command)
385
         #-(or allegro clisp ecl) command)
386
        (t command)))
387
      (list (escape-shell-command
388
389
             (os-cond
              ((os-unix-p) (cons "exec" command))
390
              ((os-windows-p)
391
               #+(or allegro clisp ecl sbcl)
Elias Pipping's avatar
Elias Pipping committed
392
               (list* "cmd" "/c" command)
393
               #-(or allegro clisp ecl sbcl) command)
394
              (t command))))))
395

396
  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
397
398
399
400
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
401
                       (string (parse-native-namestring spec))
402
403
                       (pathname spec)
                       ((eql :output)
404
                        (unless (equal operator " 2>>")
405
406
                          (parameter-error "~S: only the ~S argument can be ~S"
                                           'run-program :error-output :output))
407
408
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
409
                 (list operator " "
410
                       (escape-shell-token (native-namestring pathname)))))))
411
      (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>")))
412
             (normalized (%normalize-system-command command))
413
             (directory (or directory #+(or abcl xcl) (getcwd)))
414
415
416
417
418
             (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 " & ")))))))
419
        (reduce/strcat
420
421
         (os-cond
          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
422
          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
423

424
  (defun %system (command &rest keys &key directory
425
426
427
                                       input (if-input-does-not-exist :error)
                                       output (if-output-exists :supersede)
                                       error-output (if-error-output-exists :supersede)
428
                                       &allow-other-keys)
429
    "A portable abstraction of a low-level call to libc's system()."
Elias Pipping's avatar
Elias Pipping committed
430
431
    (declare (ignorable keys directory input if-input-does-not-exist output
                        if-output-exists error-output if-error-output-exists))
432
    #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
433
434
435
436
437
438
    (let (#+(or abcl ecl mkcl)
            (version (parse-version
                      #-abcl
                      (lisp-implementation-version)
                      #+abcl
                      (second (split-string (implementation-identifier) :separator '(#\-))))))
439
      (nest
440
       #+abcl (unless (lexicographic< '< version '(1 4 0)))
441
       #+ecl (unless (lexicographic<= '< version '(16 0 0)))
442
       #+mkcl (unless (lexicographic<= '< version '(1 1 9)))
443
444
445
       (return-from %system
         (wait-process
          (apply 'launch-program (%normalize-system-command command) keys)))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
446
    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
447
    (let ((%command (%redirected-system-command command input output error-output directory)))
Elias Pipping's avatar
Elias Pipping committed
448
449
450
451
      ;; see comments for these functions
      (%handle-if-does-not-exist input if-input-does-not-exist)
      (%handle-if-exists output if-output-exists)
      (%handle-if-exists error-output if-error-output-exists)
452
453
454
455
456
      #+abcl (ext:run-shell-command %command)
      #+(or clasp ecl) (let ((*standard-input* *stdin*)
                             (*standard-output* *stdout*)
                             (*error-output* *stderr*))
                         (ext:system %command))
457
      #+clisp
458
459
460
461
462
463
464
465
466
      (let ((raw-exit-code
             (or
              #.`(#+os-windows ,@'(ext:run-shell-command %command)
                  #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command))
                  :wait t :input :terminal :output :terminal)
              0)))
        (if (minusp raw-exit-code)
            (- 128 raw-exit-code)
            raw-exit-code))
467
468
469
      #+cormanlisp (win32:system %command)
      #+gcl (system:system %command)
      #+genera (not-implemented-error '%system)
470
471
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
472
473
474
      #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
      #+mkcl (mkcl:system %command)
      #+xcl (system:%run-shell-command %command)))
475
476
477

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
478
    ;; helper for RUN-PROGRAM when using %system
479
480
481
482
483
484
    (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)
485
486
487
488
489
490
            (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)
491
492
493
      (values output-result error-output-result exit-code)))

  (defun run-program (command &rest keys
494
                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
495
                         input (if-input-does-not-exist :error)
496
                         output (if-output-exists :supersede)
497
                         error-output (if-error-output-exists :supersede)
498
499
                         (element-type #-clozure *default-stream-element-type* #+clozure 'character)
                         (external-format *utf-8-external-format*)
500
                       &allow-other-keys)
501
    "Run program specified by COMMAND,
502
either a list of strings specifying a program and list of arguments,
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
503
504
505
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.
506

507
Always call a shell (rather than directly execute the command when possible)
508
509
if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
specified to be NIL.
510

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

514
515
If OUTPUT is a pathname, a string designating a pathname, or NIL (the default)
designating the null device, the file at that path is used as output.
516
517
518
519
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.
520
Otherwise, OUTPUT should be a value that is a suitable first argument to
521
SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
522
523
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,
524
525
526
527
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.
528
529
And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
stripped of any ending newline.
530

531
532
533
534
535
536
IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
default). The meaning of these values and their effect on the case
where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
to OPEN with :DIRECTION :OUTPUT.

537
538
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*.
539
540
Also :OUTPUT means redirecting the error output to the output stream,
in which case NIL is returned.
541

542
543
544
IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
affects ERROR-OUTPUT rather than OUTPUT.

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

548
549
550
551
552
IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
or a pathname, can take the values :CREATE and :ERROR (the
default). The meaning of these values is analogous to the
IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.

Elias Pipping's avatar
Elias Pipping committed
553
ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
554
to your Lisp implementation, when applicable, for creation of the output stream.
555
556

One and only one of the stream slurping or vomiting may or may not happen
557
558
559
560
561
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.
562
563
564
565
566
567

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"
568
569
    (declare (ignorable input output error-output if-input-does-not-exist if-output-exists
                        if-error-output-exists element-type external-format ignore-error-status))
570
    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
Elias Pipping's avatar
Elias Pipping committed
571
    (not-implemented-error 'run-program)
572
    (apply (if (or force-shell
573
574
575
576
577
578
                   ;; 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]
                   (and (stringp command)
                        (or (not force-shell-suppliedp)
                            #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t))))
                   #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t
579
580
                   ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
                   #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
581
                                   (lexicographic<= '< ver '(16 0 0)))
582
                   #+(and lispworks os-unix) (%interactivep input output error-output))
583
               '%use-system '%use-launch-program)
584
           command keys)))
585