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

4
5
6
7
(uiop/package:define-package :uiop/run-program
  (:nicknames :asdf/run-program)
  (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
  (:use :uiop/common-lisp :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
16
   #: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
33
34
35
36
37
38
39
40
41
42
43
44
45
    (some
     (cond
       ((and good-chars bad-chars)
        (error "only one of good-chars and bad-chars can be provided"))
       ((functionp good-chars)
        (complement good-chars))
       ((functionp bad-chars)
        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
78
79
    (labels ((issue (c) (princ c s))
             (issue-backslash (n) (loop :repeat n :do (issue #\\))))
      (loop
        :initially (issue #\") :finally (issue #\")
        :with l = (length x) :with i = 0
        :for i+1 = (1+ i) :while (< i l) :do
          (case (char x i)
            ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
            ((#\\)
             (let* ((j (and (< i+1 l) (position-if-not
                                       #'(lambda (c) (eql c #\\)) x :start i+1)))
                    (n (- (or j l) i)))
               (cond
                 ((null j)
                  (issue-backslash (* 2 n)) (setf i l))
                 ((and (< j l) (eql (char x j) #\"))
                  (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
                 (t
                  (issue-backslash n) (setf i j)))))
            (otherwise
             (issue (char x i)) (setf i i+1))))))

  (defun escape-windows-token (token &optional s)
    "Escape a string TOKEN within double-quotes if needed
80
for use within a MS Windows command-line, outputing to S."
81
82
    (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
                        :escaper 'escape-windows-token-within-double-quotes))
83

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

94
  (defun easy-sh-character-p (x)
95
    "Is X an \"easy\" character that does not require quoting by the shell?"
96
    (or (alphanumericp x) (find x "+-_.,%@:/")))
97

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

  (defun escape-shell-token (token &optional s)
105
    "Escape a token for the current operating system shell"
106
107
108
109
110
111
112
    (cond
      ((os-unix-p) (escape-sh-token token s))
      ((os-windows-p) (escape-windows-token token s))))

  (defun escape-command (command &optional s
                                  (escaper 'escape-shell-token))
    "Given a COMMAND as a list of tokens, return a string of the
113
spaced, escaped tokens, using ESCAPER to escape."
114
115
116
117
118
119
120
121
122
    (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
123
124
125
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
126
    (escape-command command s 'escape-windows-token))
127

128
129
  (defun escape-sh-command (command &optional s)
    "Escape a list of command-line arguments into a string suitable for parsing
130
by /bin/sh in POSIX"
131
    (escape-command command s 'escape-sh-token))
132

133
134
135
  (defun escape-shell-command (command &optional stream)
    "Escape a command for the current operating system's shell"
    (escape-command command stream 'escape-shell-token)))
136
137


138
;;;; Slurping a stream, typically the output of another program
139
(with-upgradability ()
140
  (defun call-stream-processor (fun processor stream)
141
142
143
144
    "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"
145
146
147
148
    (if (consp processor)
        (apply fun (first processor) stream (rest processor))
        (funcall fun processor stream)))

149
  (defgeneric slurp-input-stream (processor input-stream &key)
150
151
152
153
154
155
156
157
    (: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
158
* if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the
159
160
  INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
    \(APPLY x <stream> y\)
161
* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
162
163
164
165
166
167
168
  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.
169
* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
170
171

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

173
  #-(or gcl2.6 genera)
174
  (defmethod slurp-input-stream ((function function) input-stream &key)
175
176
    (funcall function input-stream))

177
  (defmethod slurp-input-stream ((list cons) input-stream &key)
178
    (apply (first list) input-stream (rest list)))
179
180
181

  #-(or gcl2.6 genera)
  (defmethod slurp-input-stream ((output-stream stream) input-stream
182
                                 &key linewise prefix (element-type 'character) buffer-size)
183
184
185
186
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

187
  (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
188
    (declare (ignorable x))
189
    (slurp-stream-string stream :stripped stripped))
190

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

195
  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
196
197
198
    (declare (ignorable x))
    (slurp-stream-lines stream :count count))

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

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

207
  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
208
209
210
    (declare (ignorable x))
    (slurp-stream-form stream :at at))

211
212
213
214
  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    (declare (ignorable x))
    (apply 'slurp-input-stream *standard-output* stream keys))

215
216
  (defmethod slurp-input-stream ((x null) stream &key)
    (declare (ignorable x stream))
217
218
    nil)

219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
  (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)))

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

250

251
(with-upgradability ()
252
  (defgeneric vomit-output-stream (processor output-stream &key)
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
    (: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."))

  #-(or gcl2.6 genera)
271
  (defmethod vomit-output-stream ((function function) output-stream &key)
272
273
    (funcall function output-stream))

274
  (defmethod vomit-output-stream ((list cons) output-stream &key)
275
276
277
278
    (apply (first list) output-stream (rest list)))

  #-(or gcl2.6 genera)
  (defmethod vomit-output-stream ((input-stream stream) output-stream
279
                                 &key linewise prefix (element-type 'character) buffer-size)
280
281
282
283
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

284
  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
285
286
287
288
289
290
291
292
293
    (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)
    (declare (ignorable x))
    (apply 'vomit-output-stream *standard-input* stream keys))

294
295
  (defmethod vomit-output-stream ((x null) stream &key)
    (declare (ignorable x stream))
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
    (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
316
                                 &key linewise prefix (element-type 'character) buffer-size)
317
318
319
320
321
322
323
324
325
326
    (declare (ignorable stream linewise prefix element-type buffer-size))
    (cond
      #+(or gcl2.6 genera)
      ((functionp x) (funcall x stream))
      #+(or gcl2.6 genera)
      ((input-stream-p x)
       (copy-stream-to-stream
        x stream
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
327
       (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
328
329


330
331
332
;;;; ----- Running an external program -----
;;; Simple variant of run-program with no input, and capturing output
;;; On some implementations, may output to a temporary file...
333
334
335
336
337
338
339
340
341
342
343
(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)
               (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
                       (subprocess-error-process condition)
                       (subprocess-error-command condition)
                       (subprocess-error-code condition)))))

344
345
  ;;; Internal helpers for run-program
  (defun %normalize-command (command)
346
347
    "Given a COMMAND as a list or string, transform it in a format suitable
for the implementation's underlying run-program function"
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
    (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))
       ;; NB: On other Windows implementations, this is utterly bogus
       ;; except in the most trivial cases where no quoting is needed.
       ;; Use at your own risk.
       #-(or allegro clisp clozure) (list "cmd" "/c" command))
      #+os-windows
      (list
       #+allegro (escape-windows-command command)
       #-allegro command)))

  (defun %active-io-specifier-p (specifier)
369
370
371
    "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."
372
    (not (typep specifier '(or null string pathname (member :interactive :output)
373
                            #+(or cmu (and sbcl os-unix) scl) (or stream (eql t))
374
                            #+lispworks file-stream)))) ;; not a type!? comm:socket-stream
375
376

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

  (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)))

406
407
408
409
410
411
412
413
414
415
416
417
418
  (defun %run-program (command
                       &rest keys
                       &key input (if-input-does-not-exist :error)
                         output (if-output-exists :overwrite)
                         error-output (if-error-output-exists :overwrite)
                         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.
It returns a process-info plist with possible keys:
419
420
     PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
    ;; NB: these implementations have unix vs windows set at compile-time.
421
    (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists))
422
423
    (assert (not (and wait (member :stream (list input output error-output)))))
    #-(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
424
    (progn command keys directory
425
426
427
428
429
430
           (error "run-program not available"))
    #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl)
    (let* ((%command (%normalize-command command))
           (%input (%normalize-io-specifier input :input))
           (%output (%normalize-io-specifier output :output))
           (%error-output (%normalize-io-specifier error-output :error-output))
431
           #+(and allegro os-windows) (interactive (%interactivep input output error-output))
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
           (process*
             #+allegro
             (multiple-value-list
              (apply
               'excl:run-shell-command
               #+os-unix (coerce (cons (first %command) %command) 'vector)
               #+os-windows %command
               :input %input
               :output %output
               :error-output %error-output
               :directory directory :wait wait
               #+os-windows :show-window #+os-windows (if interactive nil :hide)
               :allow-other-keys t keys))
             #-allegro
             (with-current-directory (#-sbcl directory)
               #+clisp
               (flet ((run (f &rest args)
                        (multiple-value-list
                         (apply f :input %input :output %output
                                  :allow-other-keys t `(,@args ,@keys)))))
452
                 (assert (eq %error-output :terminal))
453
                 ;;; since we now always return a code, we can't use this code path, anyway!
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
                 (etypecase %command
                   #+os-windows (string (run 'ext:run-shell-command %command))
                   (list (run 'ext:run-program (car %command)
                              :arguments (cdr %command)))))
               #+(or clozure cmu ecl sbcl scl)
               (#-ecl progn #+ecl multiple-value-list
                (apply
                 '#+(or cmu ecl scl) ext:run-program
                 #+clozure ccl:run-program #+sbcl sb-ext:run-program
                 (car %command) (cdr %command)
                 :input %input
                 :output %output
                 :error %error-output
                 :wait wait
                 :allow-other-keys t
                 (append
                  #+(or clozure cmu sbcl scl)
                  `(:if-input-does-not-exist ,if-input-does-not-exist
                    :if-output-exists ,if-output-exists
                    :if-error-exists ,if-error-output-exists)
                  #+sbcl `(:search t
                           :if-output-does-not-exist :create
                           :if-error-does-not-exist :create)
                  #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys)))))
               #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case
479
480
481
482
483
484
485
486
               (multiple-value-list
                (apply
                 'system:run-shell-command
                 (cons "/usr/bin/env" %command) ; lispworks wants a full path.
                 :input %input :if-input-does-not-exist if-input-does-not-exist
                 :output %output :if-output-exists if-output-exists
                 :error-output %error-output :if-error-output-exists if-error-output-exists
                 :wait wait :save-exit-status t :allow-other-keys t keys))))
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
           (process-info-r ()))
      (flet ((prop (key value) (push key process-info-r) (push value process-info-r)))
        #+allegro
        (cond
          (wait (prop :exit-code (first process*)))
          (separate-streams
           (destructuring-bind (in out err pid) process*
             (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))))
          (t
           (prop :process (third process*))
           (let ((x (first process*)))
             (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
               (0)
               (1 (prop :input-stream x))
               (2 (prop :output-stream x))
               (3 (prop :bidir-stream x))))
           (when (eq error-output :stream)
             (prop :error-stream (second process*)))))
        #+clisp
        (cond
          (wait (prop :exit-code (clisp-exit-code (first process*))))
          (t
           (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
             (0)
             (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*))))))
        #+(or clozure cmu sbcl scl)
        (progn
          (prop :process process*)
          (when (eq input :stream)
            (prop :input-stream
                  #+clozure (ccl:external-process-input-stream process*)
                  #+(or cmu scl) (ext:process-input process*)
                  #+sbcl (sb-ext:process-input process*)))
          (when (eq output :stream)
            (prop :output-stream
                  #+clozure (ccl:external-process-output-stream process*)
                  #+(or cmu scl) (ext:process-output process*)
                  #+sbcl (sb-ext:process-output process*)))
          (when (eq error-output :stream)
            (prop :error-output-stream
                  #+clozure (ccl:external-process-error-stream process*)
                  #+(or cmu scl) (ext:process-error process*)
                  #+sbcl (sb-ext:process-error process*))))
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
        #+ecl
        (destructuring-bind (stream code process) process*
          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
            (cond
              ((zerop mode))
              ((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)))
        #+lispworks
        (if wait
            (prop :exit-code (first process*))
            (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
              (if (zerop mode)
                  (prop :process (first process*))
                  (destructuring-bind (x err pid) process*
                    (prop :process pid)
                    (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x)
                    (when (eq error-output :stream) (prop :error-stream err))))))
556
557
558
559
560
561
562
        (nreverse process-info-r))))

  (defun %wait-process-result (process-info)
    (or (getf process-info :exit-code)
        (let ((process (getf process-info :process)))
          (when process
            ;; 1- wait
563
            #+clozure (ccl::external-process-wait process)
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
            #+(or cmu scl) (ext:process-wait process)
            #+(and ecl os-unix) (ext:external-process-wait process)
            #+sbcl (sb-ext:process-wait process)
            ;; 2- extract result
            #+allegro (sys:reap-os-subprocess :pid process :wait t)
            #+clozure (nth-value 1 (ccl:external-process-status process))
            #+(or cmu scl) (ext:process-exit-code process)
            #+ecl (nth-value 1 (ext:external-process-status process))
            #+lispworks (system:pid-exit-status process :wait t)
            #+sbcl (sb-ext:process-exit-code process)))))

  (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)

  (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)
590
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
591
592
593
594
595
596
597
    ;; 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))
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
    (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)
614
                     (with-temporary-file (:pathname tmp)
615
616
                       (ecase direction
                         (:input
617
618
619
620
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
621
622
                          (funcall fun tmp nil))
                         ((:output :error-output)
623
624
625
626
627
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
628
629
630
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
631
          #+(or cmu (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
632
633
634
635
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667

  (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)
668
            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
669
670
671

  (defun %use-run-program (command &rest keys
                           &key input output error-output ignore-error-status &allow-other-keys)
672
    ;; helper for RUN-PROGRAM when using %run-program
673
    #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
674
675
676
    (progn
      command keys input output error-output ignore-error-status ;; ignore
      (error "Not implemented on this platform"))
677
678
679
    (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))
680
           (active-error-output-p (%active-io-specifier-p error-output))
681
682
683
684
685
686
687
688
689
690
691
692
           (activity
             (cond
               (active-output-p :output)
               (active-input-p :input)
               (active-error-output-p :error-output)
               (t nil)))
           (wait (not activity))
           output-result error-output-result exit-code)
      (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)
693
                                    error-output :keys keys :setf error-output-result
694
695
696
697
698
                                    :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))
            (let ((process-info
699
700
701
                    (apply '%run-program command
                           :wait wait :input reduced-input :output reduced-output
                           :error-output (if (eq error-output :output) :output reduced-error-output)
702
                           keys)))
703
704
705
706
707
708
709
710
711
712
              (labels ((get-stream (stream-name &optional fallbackp)
                         (or (getf process-info stream-name)
                             (when fallbackp
                               (getf 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))))
713
714
715
                (unwind-protect
                     (ecase activity
                       ((nil))
716
717
                       (:input (run-activity input-activity :input-stream t))
                       (:output (run-activity output-activity :output-stream t))
718
719
720
721
722
723
724
725
726
                       (:error-output (run-activity error-output-activity :error-output-stream)))
                  (loop :for (() val) :on process-info :by #'cddr
                        :when (streamp val) :do (ignore-errors (close val)))
                  (setf exit-code
                        (%check-result (%wait-process-result process-info)
                                       :command command :process process-info
                                       :ignore-error-status ignore-error-status))))))))
      (values output-result error-output-result exit-code)))

727
  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
728
729
730
731
732
    (etypecase command
      (string command)
      (list (escape-shell-command
             (if (os-unix-p) (cons "exec" command) command)))))

733
  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
734
735
736
737
738
739
740
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
                       (string (pathname spec))
                       (pathname spec)
                       ((eql :output)
741
                        (assert (equal operator " 2>"))
742
743
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
744
                 (list operator " "
745
746
747
748
749
750
751
752
                       (escape-shell-token (native-namestring pathname)))))))
      (multiple-value-bind (before after)
          (let ((normalized (%normalize-system-command command)))
            (if (os-unix-p)
                (values '("exec") (list " ; " normalized))
                (values (list normalized) ())))
        (reduce/strcat
         (append
753
          before (redirect in "<") (redirect out ">") (redirect err " 2>")
754
755
756
          (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; "))
          after)))))

757
758
759
  (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()."
760
761
762
    (declare (ignorable input output error-output directory keys))
    #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
    (%wait-process-result
763
     (apply '%run-program (%normalize-system-command command) :wait t keys))
764
765
766
767
768
769
770
771
772
773
774
775
776
    #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl)
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
      #-(and lispworks os-windows)
      (with-current-directory ((unless (os-unix-p) directory))
        #+(or abcl xcl) (ext:run-shell-command %command)
        #+clisp (clisp-exit-code (ext:shell %command))
        #+cormanlisp (win32:system %command)
        #+ecl (let ((*standard-input* *stdin*)
                    (*standard-output* *stdout*)
                    (*error-output* *stderr*))
                (ext:system %command))
777
        #+gcl (#+gcl2.6 lisp:system #-gcl2.6 system:system %command)
778
779
780
781
782
783
784
785
786
        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
        #+mkcl ;; PROBABLY BOGUS -- ask jcb
        (multiple-value-bind (io process exit-code)
            (mkcl:run-program #+windows %command #+windows ()
                              #-windows "/bin/sh" #-windows (list "-c" %command)
                              :input t :output t)))))

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
787
    ;; helper for RUN-PROGRAM when using %system
788
789
790
791
792
793
794
    (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)
            (setf exit-code
795
                  (%check-result (apply '%system command
796
797
798
799
800
801
802
803
804
805
806
807
808
809
                                        :input reduced-input :output reduced-output
                                        :error-output reduced-error-output keys)
                                 :command command
                                 :ignore-error-status ignore-error-status)))))
      (values output-result error-output-result exit-code)))

  (defun run-program (command &rest keys
                       &key ignore-error-status force-shell
                         (input nil inputp) (if-input-does-not-exist :error)
                         output (if-output-exists :overwrite)
                         (error-output nil error-output-p) (if-error-output-exists :overwrite)
                         (element-type #-clozure *default-stream-element-type* #+clozure 'character)
                         (external-format *utf-8-external-format*)
                      &allow-other-keys)
810
    "Run program specified by COMMAND,
811
either a list of strings specifying a program and list of arguments,
812
813
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).

814
Always call a shell (rather than directly execute the command when possible)
815
if FORCE-SHELL is specified.
816

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

820
821
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.
822
823
824
825
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.
826
Otherwise, OUTPUT should be a value that is a suitable first argument to
827
SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
828
829
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,
830
831
832
833
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.
834
835
And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
stripped of any ending newline.
836
837
838

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*.
839
840
Also :OUTPUT means redirecting the error output to the output stream,
in which case NIL is returned.
841
842
843
844

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

845
846
Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
to your Lisp implementation, when applicable, for creation of the output stream.
847
848

One and only one of the stream slurping or vomiting may or may not happen
849
850
851
852
853
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.
854
855
856
857
858
859
860

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))
861
862
    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
    (error "RUN-PROGRAM not implemented for this Lisp")
863
864
865
866
    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
      (apply (if (or force-shell
                     #+(or clisp ecl) (or (not ignore-error-status) t)
                     #+clisp (eq error-output :interactive)
867
                     #+(or abcl clisp) (eq :error-output :output)
868
                     #+(and lispworks os-unix) (%interactivep input output error-output)
869
870
871
872
873
874
875
876
877
878
                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t)
                 '%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
           keys))))