run-program.lisp 56.4 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
16
17
   #:close-streams #:process-alive-p #:run-program #:terminate-process
   #:wait-process
Elias Pipping's avatar
Elias Pipping committed
18
   #:process-info-error-output #:process-info-input #:process-info-output
19
   #:subprocess-error
20
21
   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
   ))
22
(in-package :uiop/run-program)
23
24
25

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

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

55
56
  (defun escape-windows-token-within-double-quotes (x &optional s)
    "Escape a string token X within double-quotes
57
for use within a MS Windows command-line, outputing to S."
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))))))

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

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

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

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

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

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

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

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


144
;;;; Slurping a stream, typically the output of another program
145
(with-upgradability ()
146
  (defun call-stream-processor (fun processor stream)
147
148
149
150
    "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"
151
152
153
154
    (if (consp processor)
        (apply fun (first processor) stream (rest processor))
        (funcall fun processor stream)))

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

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

179
  #-genera
180
  (defmethod slurp-input-stream ((function function) input-stream &key)
181
182
    (funcall function input-stream))

183
  (defmethod slurp-input-stream ((list cons) input-stream &key)
184
    (apply (first list) input-stream (rest list)))
185

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

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

196
197
  (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
    (slurp-stream-string stream :stripped stripped))
198

199
  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
200
201
    (slurp-stream-lines stream :count count))

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

205
  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
206
207
    (slurp-stream-forms stream :count count))

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

211
212
213
  (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
214
  (defmethod slurp-input-stream ((x null) (stream t) &key)
215
216
    nil)

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

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

248

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

268
  #-genera
269
  (defmethod vomit-output-stream ((function function) output-stream &key)
270
271
    (funcall function output-stream))

272
  (defmethod vomit-output-stream ((list cons) output-stream &key)
273
274
    (apply (first list) output-stream (rest list)))

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

282
  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
283
284
285
286
287
288
289
290
    (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))

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


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

340
341
342
343
344
345
346
347
348
  ;;; 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."))))

349
350
  ;;; Internal helpers for run-program
  (defun %normalize-command (command)
351
352
    "Given a COMMAND as a list or string, transform it in a format suitable
for the implementation's underlying run-program function"
353
354
355
356
357
358
359
360
361
362
363
    (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
364
       #+mkcl (list "cmd" "/c" command)
365
       #+sbcl (list (%cmd-shell-pathname) "/c" command)
366
367
368
       ;; 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.
369
       #-(or allegro clisp clozure mkcl sbcl) (list "cmd" "/c" command))
370
371
372
373
374
375
      #+os-windows
      (list
       #+allegro (escape-windows-command command)
       #-allegro command)))

  (defun %active-io-specifier-p (specifier)
376
377
378
    "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."
379
    (not (typep specifier '(or null string pathname (member :interactive :output)
380
                            #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
381
                            #+lispworks file-stream)))) ;; not a type!? comm:socket-stream
382
383

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

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

408
409
410
  (defun %interactivep (input output error-output)
    (member :interactive (list input output error-output)))

411
412
  (defun %signal-to-exit-code (signum)
    (+ 128 signum))
413

Elias Pipping's avatar
Elias Pipping committed
414
415
416
417
418
  #+mkcl
  (defun %mkcl-signal-to-number (signal)
    (require :mk-unix)
    (symbol-value (find-symbol signal :mk-unix)))

Elias Pipping's avatar
Elias Pipping committed
419
420
421
422
423
424
  (defclass process-info ()
    ((process :initform nil)
     (input-stream :initform nil)
     (output-stream :initform nil)
     (bidir-stream :initform nil)
     (error-output-stream :initform nil)
425
426
427
428
429
430
431
     ;; For backward-compatibility, to maintain the property (zerop
     ;; exit-code) <-> success, an exit in response to a signal is
     ;; encoded as 128+signum.
     (exit-code :initform nil)
     ;; If the platform allows it, distinguish exiting with a code
     ;; >128 from exiting in response to a signal by setting this code
     (signal-code :initform nil)))
Elias Pipping's avatar
Elias Pipping committed
432

433
434
435
  (defun %run-program (command
                       &rest keys
                       &key input (if-input-does-not-exist :error)
436
437
                         output (if-output-exists :supersede)
                         error-output (if-error-output-exists :supersede)
438
439
440
441
442
443
444
                         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
445
It returns a process-info object."
446
    ;; NB: these implementations have Unix vs Windows set at compile-time.
447
    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
Elias Pipping's avatar
Elias Pipping committed
448
    #-(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
Elias Pipping's avatar
Elias Pipping committed
449
450
    (progn command keys input output error-output directory wait ;; ignore
           (not-implemented-error '%run-program))
Elias Pipping's avatar
Elias Pipping committed
451
    #-(or abcl cmucl ecl mkcl sbcl)
452
453
454
455
456
457
458
459
460
461
    (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))
Elias Pipping's avatar
Elias Pipping committed
462
    #+(or abcl clisp lispworks)
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
    (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))
Elias Pipping's avatar
Elias Pipping committed
482
    #+(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
483
    (let* ((%command (%normalize-command command))
484
           (%if-output-exists (%normalize-if-exists if-output-exists))
485
486
487
           (%input (%normalize-io-specifier input :input))
           (%output (%normalize-io-specifier output :output))
           (%error-output (%normalize-io-specifier error-output :error-output))
488
           #+(and allegro os-windows)
489
490
           (interactive (%interactivep input output error-output))
           (process*
491
492
             (nest
              #-(or allegro mkcl sbcl) (with-current-directory (directory))
493
              #+(or allegro clisp ecl lispworks mkcl) (multiple-value-list)
494
              (apply
Elias Pipping's avatar
Elias Pipping committed
495
               #+abcl #'sys:run-program
496
497
498
               #+allegro 'excl:run-shell-command
               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
               #+(and allegro os-windows) %command
499
               #+clisp
500
501
502
503
504
505
               (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
506
               #+(or cmucl ecl scl) 'ext:run-program
507
508
509
510
511
               #+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
Elias Pipping's avatar
Elias Pipping committed
512
                #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
513
514
515
516
                `(: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))
517
                #+clisp `(:if-output-exists ,%if-output-exists)
Elias Pipping's avatar
Elias Pipping committed
518
                #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
519
                `(:if-input-does-not-exist ,if-input-does-not-exist
520
                  :if-output-exists ,%if-output-exists
521
522
                  #-(or allegro lispworks) :if-error-exists
                  #+(or allegro lispworks) :if-error-output-exists
523
524
                  ,if-error-output-exists)
                #+lispworks `(:save-exit-status t)
Elias Pipping's avatar
Elias Pipping committed
525
                #+mkcl `(:directory ,(native-namestring directory))
526
                #+sbcl `(:search t)
527
528
                #-sbcl keys
                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
Elias Pipping's avatar
Elias Pipping committed
529
           (process-info (make-instance 'process-info)))
530
      #+clisp (declare (ignore %error-output))
531
532
533
534
535
536
537
      (labels ((prop (key value) (setf (slot-value process-info key) value))
               #+(or allegro clisp ecl lispworks mkcl)
               (store-codes (exit-code &optional signal-code)
                 (if signal-code
                     (progn (prop 'exit-code (%signal-to-exit-code signal-code))
                            (prop 'signal-code signal-code))
                     (prop 'exit-code exit-code))))
538
539
        #+allegro
        (cond
540
          (wait (store-codes (first process*)))
541
542
          (separate-streams
           (destructuring-bind (in out err pid) process*
Elias Pipping's avatar
Elias Pipping committed
543
544
545
546
             (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))))
547
          (t
Elias Pipping's avatar
Elias Pipping committed
548
           (prop 'process (third process*))
549
550
551
           (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
552
553
554
               (1 (prop 'input-stream x))
               (2 (prop 'output-stream x))
               (3 (prop 'bidir-stream x))))
555
           (when (eq error-output :stream)
Elias Pipping's avatar
Elias Pipping committed
556
             (prop 'error-stream (second process*)))))
557
        #+clisp
558
559
560
561
562
563
564
565
566
567
568
569
        (if wait
            (let ((raw-exit-code (or (first process*) 0)))
              (if (minusp raw-exit-code)
                  (store-codes 0 (- raw-exit-code))
                  (store-codes raw-exit-code)))
            (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*)))))
Elias Pipping's avatar
Elias Pipping committed
570
        #+(or abcl clozure cmucl sbcl scl)
571
        (progn
Elias Pipping's avatar
Elias Pipping committed
572
          (prop 'process process*)
573
          (when (eq input :stream)
Elias Pipping's avatar
Elias Pipping committed
574
            (prop 'input-stream
Elias Pipping's avatar
Elias Pipping committed
575
                  #+abcl (symbol-call :sys :process-input process*)
576
                  #+clozure (ccl:external-process-input-stream process*)
577
                  #+(or cmucl scl) (ext:process-input process*)
578
579
                  #+sbcl (sb-ext:process-input process*)))
          (when (eq output :stream)
Elias Pipping's avatar
Elias Pipping committed
580
            (prop 'output-stream
Elias Pipping's avatar
Elias Pipping committed
581
                  #+abcl (symbol-call :sys :process-output process*)
582
                  #+clozure (ccl:external-process-output-stream process*)
583
                  #+(or cmucl scl) (ext:process-output process*)
584
                  #+sbcl (sb-ext:process-output process*)))
585
          (when (eq error-output :stream)
Elias Pipping's avatar
Elias Pipping committed
586
            (prop 'error-output-stream
Elias Pipping's avatar
Elias Pipping committed
587
                  #+abcl (symbol-call :sys :process-error process*)
588
                  #+clozure (ccl:external-process-error-stream process*)
589
                  #+(or cmucl scl) (ext:process-error process*)
590
                  #+sbcl (sb-ext:process-error process*))))
591
592
        #+(or ecl mkcl)
        (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
593
594
595
          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
            (cond
              ((zerop mode))
596
              ((null process*) (store-codes -1))
Elias Pipping's avatar
Elias Pipping committed
597
              (t (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))))
598
599
600
601
          (when code
            (let ((signum #+mkcl (and (stringp code) (%mkcl-signal-to-number code))
                          #-mkcl (and (eq (ext:external-process-wait process)
                                          :signaled)
Elias Pipping's avatar
Elias Pipping committed
602
                                      code)))
603
              (store-codes code signum)))
Elias Pipping's avatar
Elias Pipping committed
604
          (when process (prop 'process process)))
605
606
        #+lispworks
        (if wait
607
            (store-codes (first process*) (second process*))
608
            (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
609
610
611
612
613
614
615
616
617
618
619
620
621
              (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
622
        process-info)))
623

Elias Pipping's avatar
Elias Pipping committed
624
625
626
627
628
629
630
631
632
  (defun process-info-error-output (process-info)
    (slot-value process-info 'error-output-stream))
  (defun process-info-input (process-info)
    (or (slot-value process-info 'bidir-stream)
        (slot-value process-info 'input-stream)))
  (defun process-info-output (process-info)
    (or (slot-value process-info 'bidir-stream)
        (slot-value process-info 'output-stream)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
633
  (defun %process-info-pid (process-info)
Elias Pipping's avatar
Elias Pipping committed
634
    (let ((process (slot-value process-info 'process)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
635
      (declare (ignorable process))
Elias Pipping's avatar
Elias Pipping committed
636
      #+abcl (symbol-call :sys :process-pid process)
637
      #+allegro process
638
      #+clozure (ccl:external-process-id process)
639
      #+ecl (ext:external-process-pid process)
640
      #+(or cmucl scl) (ext:process-pid process)
641
642
      #+lispworks7+ (sys:pipe-pid process)
      #+(and lispworks (not lispworks7+)) process
643
      #+mkcl (mkcl:process-id process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
644
      #+sbcl (sb-ext:process-pid process)
Elias Pipping's avatar
Elias Pipping committed
645
      #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
Elias Pipping's avatar
Elias Pipping committed
646
      (not-implemented-error '%process-info-pid)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
647

648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
  (defun %process-status (process-info)
    (if-let (exit-code (slot-value process-info 'exit-code))
      (return-from %process-status
        (if-let (signal-code (slot-value process-info 'signal-code))
          (values :signaled signal-code)
          (values :exited exit-code))))
    #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    (not-implemented-error '%process-status)
    (if-let (process (slot-value process-info 'process))
      (multiple-value-bind (status code)
          (progn
            #+allegro (multiple-value-bind (exit-code pid signal)
                          (sys:reap-os-subprocess :pid process :wait nil)
                        (assert pid)
                        (cond ((null exit-code) :running)
                              ((null signal) (values :exited exit-code))
                              (t (values :signaled signal))))
            #+clozure (ccl:external-process-status process)
            #+(or cmucl scl) (let ((status (ext:process-status process)))
                               (values status (if (member status '(:exited :signaled))
                                                  (ext:process-exit-code process))))
            #+ecl (ext:external-process-status process)
            #+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 nil)
              (cond ((null exit-code) :running)
                    ((null signal) (values :exited exit-code))
                    (t (values :signaled signal))))
            #+mkcl (let ((status (mk-ext:process-status process))
                         (code (mk-ext:process-exit-code process)))
                     (if (stringp code)
                         (values :signaled (%mkcl-signal-to-number code))
                         (values status code)))
            #+sbcl (let ((status (sb-ext:process-status process)))
                     (values status (if (member status '(:exited :signaled))
                                        (sb-ext:process-exit-code process)))))
        (case status
          (:exited (setf (slot-value process-info 'exit-code) code))
          (:signaled (let ((%code (%signal-to-exit-code code)))
                       (setf (slot-value process-info 'exit-code) %code
                             (slot-value process-info 'signal-code) code))))
        (values status code))))

  (defun process-alive-p (process-info)
    "Check if a process has yet to exit."
    (unless (slot-value process-info 'exit-code)
      #+abcl (sys:process-alive-p (slot-value process-info 'process))
      #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
      #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
      #-(or abcl cmucl sbcl scl) (member (%process-status process-info)
                                         '(:running :sleeping))))

703
704
705
706
  (defun wait-process (process-info)
    "Wait for the process to terminate, if it is still running.
Otherwise, return immediately. An exit code (a number) will be
returned, with 0 indicating success, and anything else indicating
707
708
709
failure. If the process exits after receiving a signal, the exit code
will be the sum of 128 and the (positive) numeric signal code. A second
value may be returned in this case: the numeric signal code itself.
710
711
712
Any asynchronously spawned process requires this function to be run
before it is garbage-collected in order to free up resources that
might otherwise be irrevocably lost."
713
714
715
716
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
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
    (if-let (exit-code (slot-value process-info 'exit-code))
      (if-let (signal-code (slot-value process-info 'signal-code))
        (values exit-code signal-code)
        exit-code)
      (let ((process (slot-value process-info 'process)))
        #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
        (not-implemented-error 'wait-process)
        (when process
          ;; 1- wait
          #+clozure (ccl::external-process-wait process)
          #+(or cmucl scl) (ext:process-wait process)
          #+sbcl (sb-ext:process-wait process)
          ;; 2- extract result
          (multiple-value-bind (exit-code signal-code)
              (progn
                #+abcl (sys:process-wait process)
                #+allegro (multiple-value-bind (exit-code pid signal)
                              (sys:reap-os-subprocess :pid process :wait t)
                            (assert pid)
                            (values exit-code signal))
                #+clozure (multiple-value-bind (status code)
                              (ccl:external-process-status process)
                            (if (eq status :signaled)
                                (values nil code)
                                code))
                #+(or cmucl scl) (let ((status (ext:process-status process))
                                       (code (ext:process-exit-code process)))
                                   (if (eq status :signaled)
                                       (values nil code)
                                       code))
                #+ecl (multiple-value-bind (status code)
                          (ext:external-process-wait process t)
                        (if (eq status :signaled)
                            (values nil code)
                            code))
                #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
                                     #-lispworks7+ #'sys:pid-exit-status
                                     process :wait t)
                #+mkcl (let ((code (mkcl:join-process process)))
                         (if (stringp code)
                             (values nil (%mkcl-signal-to-number code))
                             code))
                #+sbcl (let ((status (sb-ext:process-status process))
                             (code (sb-ext:process-exit-code process)))
                         (if (eq status :signaled)
                             (values nil code)
                             code)))
            (if signal-code
                (let ((%exit-code (%signal-to-exit-code signal-code)))
                  (setf (slot-value process-info 'exit-code) %exit-code
                        (slot-value process-info 'signal-code) signal-code)
                  (values %exit-code signal-code))
                (progn (setf (slot-value process-info 'exit-code) exit-code)
                       exit-code)))))))
767
768
769
770
771
772
773
774

  (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
775
776
777
778
779
780
781
782
783
784
785
786
  (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))))

787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
  ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
  ;; do what you expect it to. Sending SIGSTOP to a process spawned
  ;; via %run-program, e.g., will stop the shell /bin/sh that is used
  ;; to run the command (via `sh -c command`) but not the actual
  ;; command.
  (defun %posix-send-signal (process-info signal)
    #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
    #+clozure (ccl:signal-external-process (slot-value process-info 'process)
                                           signal :error-if-exited nil)
    #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
    #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
    #-(or allegro clozure cmucl sbcl scl)
    (if-let (pid (%process-info-pid process-info))
      (%run-program (format nil "kill -~a ~a" signal pid) :wait t)))

  (defun terminate-process (process-info &key urgent)
    "Cause the process to exit. To that end, the process may or may
not be sent a signal, which it will find harder (or even impossible)
to ignore if URGENT is T. On some platforms, it may also be subject to
race conditions."
    (declare (ignorable urgent))
    #+abcl (sys:process-kill (slot-value process-info 'process))
    #+ecl (symbol-call :ext :terminate-process
                       (slot-value process-info 'process) urgent)
    #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
    #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
                                     :force urgent)
    #-(or abcl ecl lispworks7+ mkcl)
    (os-cond
     ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
     ((os-windows-p) (if-let (pid (%process-info-pid process-info))
                       (%run-program (format nil "taskkill ~a /pid ~a"
                                             (if urgent "/f" "") pid))))
     (t (not-implemented-error 'terminate-process))))

822
823
824
825
826
827
828
829
  (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)
830
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
831
832
833
834
835
836
837
    ;; 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))
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
    (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)
854
                     (with-temporary-file (:pathname tmp)
855
856
                       (ecase direction
                         (:input
857
858
859
860
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
861
862
                          (funcall fun tmp nil))
                         ((:output :error-output)
863
864
865
866
867
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
868
869
870
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
871
          #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
872
873
874
875
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907

  (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)
908
            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
909
910
911

  (defun %use-run-program (command &rest keys
                           &key input output error-output ignore-error-status &allow-other-keys)
912
    ;; helper for RUN-PROGRAM when using %run-program
Elias Pipping's avatar
Elias Pipping committed
913
    #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
914
915
    (progn
      command keys input output error-output ignore-error-status ;; ignore
Elias Pipping's avatar
Elias Pipping committed
916
      (not-implemented-error '%use-run-program))
917
918
919
    (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))
920
           (active-error-output-p (%active-io-specifier-p error-output))
921
922
923
924
925
926
927
           (activity
             (cond
               (active-output-p :output)
               (active-input-p :input)
               (active-error-output-p :error-output)
               (t nil)))
           (wait (not activity))
928
           output-result error-output-result exit-code process-info)
929
930
931
932
      (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)
933
                                    error-output :keys keys :setf error-output-result
934
935
936
937
                                    :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))
938
            (setf process-info
Elias Pipping's avatar
Elias Pipping committed
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
                  (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
959
                (close-streams process-info)
960
                (setf exit-code (wait-process process-info)))))))
961
962
963
      (%check-result exit-code
                     :command command :process process-info
                     :ignore-error-status ignore-error-status)
964
965
      (values output-result error-output-result exit-code)))

966
  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
967
    (etypecase command
968
969
970
      (string
       (os-cond
        ((os-windows-p)
971
972
973
         #+(or allegro clisp)
         (strcat (%cmd-shell-pathname) " /c " command)
         #-(or allegro clisp) command)
974
        (t command)))
975
      (list (escape-shell-command
976
977
             (os-cond
              ((os-unix-p) (cons "exec" command))
978
979
980
981
              ((os-windows-p)
               #+(or allegro sbcl clisp)
               (cons (%cmd-shell-pathname) (cons "/c" command))
               #-(or allegro sbcl clisp) command)
982
              (t command))))))
983

984
  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
985
986
987
988
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
989
                       (string (parse-native-namestring spec))
990
991
                       (pathname spec)
                       ((eql :output)
992
                        (assert (equal operator " 2>"))
993
994
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
995
                 (list operator " "
996
                       (escape-shell-token (native-namestring pathname)))))))
997
998
      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
             (normalized (%normalize-system-command command))
999
             (directory (or directory #+(or abcl xcl) (getcwd)))
1000
1001
1002
1003
1004
             (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 " & ")))))))
1005
        (reduce/strcat
1006
1007
         (os-cond
          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
1008
          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
1009

1010
1011
1012
  (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()."
1013
    (declare (ignorable input output error-output directory keys))
1014
    #+(or allegro clozure cmucl (and lispworks os-unix) sbcl scl)
1015
    (wait-process
1016
     (apply '%run-program (%normalize-system-command command) :wait t keys))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1017
    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
1018
1019
1020
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
1021
      #+clisp
1022
      (wait-process
1023
1024
1025
       (apply '%run-program %command :wait t
              :input :interactive :output :interactive :error-output :interactive keys))
      #-(or clisp (and lispworks os-windows))
1026
      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
Elias Pipping's avatar
Elias Pipping committed
1027
        #+abcl (ext:run-shell-command %command) ;; FIXME: deprecated
1028
        #+cormanlisp (win32:system %command)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1029
        #+(or clasp ecl) (let ((*standard-input* *stdin*)
1030
1031
1032
                    (*standard-output* *stdout*)
                    (*error-output* *stderr*))
                (ext:system %command))
1033
        #+gcl (system:system %command)
Elias Pipping's avatar
Elias Pipping committed
1034
        #+genera (not-implemented-error '%system)
1035
        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
1036
        #+mkcl (mkcl:system %command)
1037
        #+xcl (system:%run-shell-command %command))))
1038
1039
1040

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
1041
    ;; helper for RUN-PROGRAM when using %system
1042
1043
1044
1045
1046
1047
    (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)
1048
1049
1050
1051
1052
1053
            (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)
1054
1055
1056
      (values output-result error-output-result exit-code)))

  (defun run-program (command &rest keys
1057
                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
1058
                         (input nil inputp) (if-input-does-not-exist :error)
1059
1060
                         output (if-output-exists :supersede)
                         (error-output nil error-output-p) (if-error-output-exists :supersede)
1061
1062
1063
                         (element-type #-clozure *default-stream-element-type* #+clozure 'character)
                         (external-format *utf-8-external-format*)
                      &allow-other-keys)
1064
    "Run program specified by COMMAND,
1065
either a list of strings specifying a program and list of arguments,
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1066
1067
1068
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.
1069

1070
Always call a shell (rather than directly execute the command when possible)
1071
1072
if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
specified to be NIL.
1073

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

1077
1078
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.