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

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

14
   ;;; run-program
15
   #:slurp-input-stream #:vomit-output-stream
Elias Pipping's avatar
Elias Pipping committed
16
17
   #:close-streams #:launch-program #: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
Elias Pipping's avatar
Elias Pipping committed
19
   #:process-info-pid
20
   #:subprocess-error
21
22
   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
   ))
23
(in-package :uiop/run-program)
24
25
26

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

249

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

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

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

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

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

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


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

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

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

  (defun %active-io-specifier-p (specifier)
377
378
379
    "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."
380
    (not (typep specifier '(or null string pathname (member :interactive :output)
381
                            #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
Elias Pipping's avatar
Elias Pipping committed
382
                            #+lispworks file-stream))))
383
384

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

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

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

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

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

Elias Pipping's avatar
Elias Pipping committed
420
421
422
423
424
425
  (defclass process-info ()
    ((process :initform nil)
     (input-stream :initform nil)
     (output-stream :initform nil)
     (bidir-stream :initform nil)
     (error-output-stream :initform nil)
426
427
428
429
430
431
432
     ;; 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
433

434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
  (defun launch-program (command &rest keys
                         &key
                           input (if-input-does-not-exist :error)
                           output (if-output-exists :supersede)
                           error-output (if-error-output-exists :supersede)
                           (element-type #-clozure *default-stream-element-type*
                                         #+clozure 'character)
                           (external-format *utf-8-external-format*)
                           directory wait
                           #+allegro separate-streams
                           &allow-other-keys)
    "Launch program specified by COMMAND,
either a list of strings specifying a program and list of arguments,
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
Windows) _asynchronously_.

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.
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.  If it's :STREAM, a new
stream will be made available that can be accessed via
PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
that the underlying lisp implementation knows how to handle.

ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
:OUTPUT means redirecting the error output to the output stream,
and :STREAM causes a stream to be made available via
PROCESS-INFO-ERROR-OUTPUT.

INPUT is similar to OUTPUT, except that T designates the
*STANDARD-INPUT* and a stream requested through the :STREAM keyword
would be available through PROCESS-INFO-INPUT.

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

LAUNCH-PROGRAM returns a PROCESS-INFO object."
473
    ;; NB: these implementations have Unix vs Windows set at compile-time.
474
    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
Elias Pipping's avatar
Elias Pipping committed
475
    #-(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
476
477
    (progn command keys input output error-output directory wait element-type external-format ;; ignore
           (not-implemented-error 'launch-program))
Elias Pipping's avatar
Elias Pipping committed
478
    #-(or abcl cmucl ecl mkcl sbcl)
479
480
    (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"
481
                       'launch-program :stream :wait t))
482
483
484
485
486
487
    #+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"
488
                       'launch-program))
Elias Pipping's avatar
Elias Pipping committed
489
    #+(or abcl clisp lispworks)
490
491
    (when (some #'streamp (list input output error-output))
      (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
492
                       'launch-program))
493
494
495
    #+clisp
    (unless (eq error-output :interactive)
      (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
496
                       'launch-program :error-output :interactive))
497
498
499
500
    #+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"
501
                         'launch-program :input)))
502
503
504
505
506
507
    #+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"
508
                       'launch-program))
Elias Pipping's avatar
Elias Pipping committed
509
    #+(or abcl allegro clisp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
510
    (let* ((%command (%normalize-command command))
511
           (%if-output-exists (%normalize-if-exists if-output-exists))
512
513
514
           (%input (%normalize-io-specifier input :input))
           (%output (%normalize-io-specifier output :output))
           (%error-output (%normalize-io-specifier error-output :error-output))
515
           #+(and allegro os-windows)
516
517
           (interactive (%interactivep input output error-output))
           (process*
518
519
             (nest
              #-(or allegro mkcl sbcl) (with-current-directory (directory))
520
              #+(or allegro clisp ecl lispworks mkcl) (multiple-value-list)
521
              (apply
Elias Pipping's avatar
Elias Pipping committed
522
               #+abcl #'sys:run-program
523
524
525
               #+allegro 'excl:run-shell-command
               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
               #+(and allegro os-windows) %command
526
               #+clisp
527
528
529
530
531
532
               (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
533
               #+(or cmucl ecl scl) 'ext:run-program
534
535
536
537
538
               #+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
539
                #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
540
541
542
                `(:input ,%input :output ,%output :wait ,wait
                  :element-type ,element-type :external-format ,external-format
                  :allow-other-keys t)
543
544
545
                #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error
                            ,%error-output)
                #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
546
                #+clisp `(:if-output-exists ,%if-output-exists)
Elias Pipping's avatar
Elias Pipping committed
547
                #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
548
                `(:if-input-does-not-exist ,if-input-does-not-exist
549
                  :if-output-exists ,%if-output-exists
550
551
                  #-(or allegro lispworks) :if-error-exists
                  #+(or allegro lispworks) :if-error-output-exists
552
553
                  ,if-error-output-exists)
                #+lispworks `(:save-exit-status t)
Elias Pipping's avatar
Elias Pipping committed
554
                #+mkcl `(:directory ,(native-namestring directory))
555
                #+sbcl `(:search t)
556
557
                #-sbcl keys
                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
Elias Pipping's avatar
Elias Pipping committed
558
           (process-info (make-instance 'process-info)))
559
      #+clisp (declare (ignore %error-output))
560
561
562
563
564
565
566
      (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))))
567
568
        #+allegro
        (cond
569
          (wait (store-codes (first process*)))
570
571
          (separate-streams
           (destructuring-bind (in out err pid) process*
Elias Pipping's avatar
Elias Pipping committed
572
573
574
575
             (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))))
576
          (t
Elias Pipping's avatar
Elias Pipping committed
577
           (prop 'process (third process*))
578
579
580
           (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
581
582
583
               (1 (prop 'input-stream x))
               (2 (prop 'output-stream x))
               (3 (prop 'bidir-stream x))))
584
           (when (eq error-output :stream)
Elias Pipping's avatar
Elias Pipping committed
585
             (prop 'error-stream (second process*)))))
586
        #+clisp
587
588
589
590
591
592
593
594
595
596
597
598
        (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
599
        #+(or abcl clozure cmucl sbcl scl)
600
        (progn
Elias Pipping's avatar
Elias Pipping committed
601
          (prop 'process process*)
602
          (when (eq input :stream)
Elias Pipping's avatar
Elias Pipping committed
603
            (prop 'input-stream
Elias Pipping's avatar
Elias Pipping committed
604
                  #+abcl (symbol-call :sys :process-input process*)
605
                  #+clozure (ccl:external-process-input-stream process*)
606
                  #+(or cmucl scl) (ext:process-input process*)
607
608
                  #+sbcl (sb-ext:process-input process*)))
          (when (eq output :stream)
Elias Pipping's avatar
Elias Pipping committed
609
            (prop 'output-stream
Elias Pipping's avatar
Elias Pipping committed
610
                  #+abcl (symbol-call :sys :process-output process*)
611
                  #+clozure (ccl:external-process-output-stream process*)
612
                  #+(or cmucl scl) (ext:process-output process*)
613
                  #+sbcl (sb-ext:process-output process*)))
614
          (when (eq error-output :stream)
Elias Pipping's avatar
Elias Pipping committed
615
            (prop 'error-output-stream
Elias Pipping's avatar
Elias Pipping committed
616
                  #+abcl (symbol-call :sys :process-error process*)
617
                  #+clozure (ccl:external-process-error-stream process*)
618
                  #+(or cmucl scl) (ext:process-error process*)
619
                  #+sbcl (sb-ext:process-error process*))))
620
621
        #+(or ecl mkcl)
        (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
622
623
624
          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
            (cond
              ((zerop mode))
625
              ((null process*) (store-codes -1))
Elias Pipping's avatar
Elias Pipping committed
626
              (t (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))))
627
628
629
630
          (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
631
                                      code)))
632
              (store-codes code signum)))
Elias Pipping's avatar
Elias Pipping committed
633
          (when process (prop 'process process)))
634
635
        #+lispworks
        (if wait
636
            (store-codes (first process*) (second process*))
637
            (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
638
639
640
641
642
643
644
645
646
647
648
649
650
              (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
651
        process-info)))
652

653
654
655
656
  (defun %run-program (command &rest keys &key &allow-other-keys)
    "DEPRECATED. Use LAUNCH-PROGRAM instead."
    (apply 'launch-program command keys))

Elias Pipping's avatar
Elias Pipping committed
657
658
659
660
661
662
663
664
665
  (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)))

Elias Pipping's avatar
Elias Pipping committed
666
  (defun process-info-pid (process-info)
Elias Pipping's avatar
Elias Pipping committed
667
    (let ((process (slot-value process-info 'process)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
668
      (declare (ignorable process))
Elias Pipping's avatar
Elias Pipping committed
669
      #+abcl (symbol-call :sys :process-pid process)
670
      #+allegro process
671
      #+clozure (ccl:external-process-id process)
672
      #+ecl (ext:external-process-pid process)
673
      #+(or cmucl scl) (ext:process-pid process)
674
675
      #+lispworks7+ (sys:pipe-pid process)
      #+(and lispworks (not lispworks7+)) process
676
      #+mkcl (mkcl:process-id process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
677
      #+sbcl (sb-ext:process-pid process)
Elias Pipping's avatar
Elias Pipping committed
678
      #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
Elias Pipping's avatar
Elias Pipping committed
679
      (not-implemented-error 'process-info-pid)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
680

681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
  (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))))

736
737
738
739
  (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
740
741
742
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.
743
744
745
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."
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
    (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)))))))
800
801
802
803
804
805
806
807

  (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
808
809
810
811
812
813
814
815
816
817
818
819
  (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))))

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
822
  ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
823
824
  ;; to run the command (via `sh -c command`) but not the actual
  ;; command.
Robert Goldman's avatar
Robert Goldman committed
825
  #+os-unix
826
827
828
829
830
831
832
  (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)
Elias Pipping's avatar
Elias Pipping committed
833
    (if-let (pid (process-info-pid process-info))
834
835
      (run-program (format nil "kill -~a ~a" signal pid)
                   :ignore-error-status t)))
836

Robert Goldman's avatar
Robert Goldman committed
837
838
839
840
841
842
843
  ;;; this function never gets called on Windows, but the compiler cannot tell
  ;;; that. [2016/09/25:rpg]
  #+os-windows
  (defun %posix-send-signal (process-info signal)
    (declare (ignore process-info signal))
    (values))

844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
  (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)))
Elias Pipping's avatar
Elias Pipping committed
859
     ((os-windows-p) (if-let (pid (process-info-pid process-info))
860
861
862
                       (run-program (format nil "taskkill ~a /pid ~a"
                                            (if urgent "/f" "") pid)
                                    :ignore-error-status t)))
863
864
     (t (not-implemented-error 'terminate-process))))

865
866
867
868
869
870
871
872
  (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)
873
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
874
875
876
877
878
879
880
    ;; 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))
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
    (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)
897
                     (with-temporary-file (:pathname tmp)
898
899
                       (ecase direction
                         (:input
900
901
902
903
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
904
905
                          (funcall fun tmp nil))
                         ((:output :error-output)
906
907
908
909
910
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
911
912
913
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
914
          #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
915
916
917
918
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950

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

953
  (defun %use-launch-program (command &rest keys
954
                           &key input output error-output ignore-error-status &allow-other-keys)
955
    ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
Elias Pipping's avatar
Elias Pipping committed
956
    #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
957
958
    (progn
      command keys input output error-output ignore-error-status ;; ignore
959
      (not-implemented-error '%use-launch-program))
960
961
962
    (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))
963
           (active-error-output-p (%active-io-specifier-p error-output))
964
965
966
967
968
969
970
           (activity
             (cond
               (active-output-p :output)
               (active-input-p :input)
               (active-error-output-p :error-output)
               (t nil)))
           (wait (not activity))
971
           output-result error-output-result exit-code process-info)
972
973
974
975
      (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)
976
                                    error-output :keys keys :setf error-output-result
977
978
979
980
                                    :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))
981
            (setf process-info
982
                  (apply 'launch-program command
Elias Pipping's avatar
Elias Pipping committed
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
                         :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
1002
                (close-streams process-info)
1003
                (setf exit-code (wait-process process-info)))))))
1004
1005
1006
      (%check-result exit-code
                     :command command :process process-info
                     :ignore-error-status ignore-error-status)
1007
1008
      (values output-result error-output-result exit-code)))

1009
  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
1010
    (etypecase command
1011
1012
1013
      (string
       (os-cond
        ((os-windows-p)
1014
1015
1016
         #+(or allegro clisp)
         (strcat (%cmd-shell-pathname) " /c " command)
         #-(or allegro clisp) command)
1017
        (t command)))
1018
      (list (escape-shell-command
1019
1020
             (os-cond
              ((os-unix-p) (cons "exec" command))
1021
1022
1023
1024
              ((os-windows-p)
               #+(or allegro sbcl clisp)
               (cons (%cmd-shell-pathname) (cons "/c" command))
               #-(or allegro sbcl clisp) command)
1025
              (t command))))))
1026

1027
  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
1028
1029
1030
1031
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
1032
                       (string (parse-native-namestring spec))
1033
1034
                       (pathname spec)
                       ((eql :output)
1035
                        (assert (equal operator " 2>"))
1036
1037
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
1038
                 (list operator " "
1039
                       (escape-shell-token (native-namestring pathname)))))))
1040
1041
      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
             (normalized (%normalize-system-command command))
1042
             (directory (or directory #+(or abcl xcl) (getcwd)))
1043
1044
1045
1046
1047
             (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 " & ")))))))
1048
        (reduce/strcat
1049
1050
         (os-cond
          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
1051
          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
1052

1053
1054
1055
  (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()."
1056
    (declare (ignorable input output error-output directory keys))
1057
    #+(or allegro clozure cmucl (and lispworks os-unix) sbcl scl)
1058
    (wait-process
1059
     (apply 'launch-program (%normalize-system-command command) :wait t keys))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1060
    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
1061
1062
1063
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
1064
      #+clisp
1065
      (wait-process
1066
       (apply 'launch-program %command :wait t
1067
1068
              :input :interactive :output :interactive :error-output :interactive keys))
      #-(or clisp (and lispworks os-windows))
1069
      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
Elias Pipping's avatar
Elias Pipping committed
1070
        #+abcl (ext:run-shell-command %command) ;; FIXME: deprecated
1071
        #+cormanlisp (win32:system %command)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1072
        #+(or clasp ecl) (let ((*standard-input* *stdin*)
1073
1074
1075
                               (*standard-output* *stdout*)
                               (*error-output* *stderr*))
                           (ext:system %command))