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

4
5
6
(uiop/package:define-package :uiop/run-program
  (:nicknames :asdf/run-program)
  (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
7
8
  (:use :uiop/common-lisp :uiop/package :uiop/utility
   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
9
10
11
12
13
14
  (: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

15
   ;;; run-program
16
   #:slurp-input-stream #:vomit-output-stream
17
   #:run-program
18
   #:subprocess-error
19
20
   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
   ))
21
(in-package :uiop/run-program)
22
23
24

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

247

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

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

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

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

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

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


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

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

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

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

  (defun %normalize-io-specifier (specifier &optional role)
383
384
    "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent
argument to pass to the internal RUN-PROGRAM"
385
386
387
    (declare (ignorable role))
    (etypecase specifier
      (null (or #+(or allegro lispworks) (null-device-pathname)))
388
      (string (parse-native-namestring specifier))
389
390
391
392
393
394
395
396
397
      (pathname
       #-ecl specifier
       #+ecl (let ((s (apply 'open specifier :direction
                             (ecase role
                               ((:input)
                                '(:input :if-does-not-exist :error))
                               ((:output :error-output)
                                '(:output :if-does-not-exist :create :if-exists :rename-and-delete))))))
               (values s s)))
398
399
400
401
402
      (stream specifier)
      ((eql :stream) :stream)
      ((eql :interactive)
       #+allegro nil
       #+clisp :terminal
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
403
404
       #+(or clasp clozure cmu ecl mkcl sbcl scl) t)
      #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl)
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
      ((eql :output)
       (if (eq role :error-output)
           :output
           (error "Wrong specifier ~S for role ~S" specifier role)))))

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

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

420
421
422
423
424
425
  (defun call-with-open-streams (streams thunk)
    (unwind-protect (funcall thunk) (dolist (s streams) (ignore-errors (close s)))))

  (defmacro with-open-streams ((streams) &body body)
    `(call-with-closing ,streams #'(lambda () ,@body)))

426
427
428
429
430
431
432
433
434
435
436
437
438
  (defun %run-program (command
                       &rest keys
                       &key input (if-input-does-not-exist :error)
                         output (if-output-exists :overwrite)
                         error-output (if-error-output-exists :overwrite)
                         directory wait
                         #+allegro separate-streams
                         &allow-other-keys)
    "A portable abstraction of a low-level call to the implementation's run-program or equivalent.
It spawns a subprocess that runs the specified COMMAND (a list of program and arguments).
INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
to be normalized by %NORMALIZE-IO-SPECIFIER.
It returns a process-info plist with possible keys:
439
     PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
440
    ;; NB: these implementations have Unix vs Windows set at compile-time.
441
    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
442
    (assert (not (and wait (member :stream (list input output error-output)))))
443
    #-(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl)
444
    (progn command keys directory
445
           (error "run-program not available"))
446
    #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl)
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
    (nest
     (let ((%command (%normalize-command command))
           #+ecl (close-me '())))
     (multiple-value-bind (%input #+ecl i-close)
         (%normalize-io-specifier input :input)
       #+ecl (when i-close (push i-close close-me)))
     (multiple-value-bind (%output #+ecl o-close)
         (%normalize-io-specifier output :output)
       #+ecl (when o-close (push o-close close-me)))
     (multiple-value-bind (%error-output #+ecl e-close)
         (%normalize-io-specifier error-output :error-output)
       #+ecl (when e-close (push e-close close-me)))
     #+(and allegro os-windows) (let ((interactive (%interactivep input output error-output))))
     (let ((process*
             (nest
              #+clisp (progn
                        ;; clisp cannot redirect stderr, so check we don't.
                        ;; Also, since we now always return a code, we cannot use this code path
                        ;; if any of the input, output or error-output is :stream.
                        (assert (eq %error-output :terminal)))
              #+ecl (with-open-streams (close-me))
              #-(or allegro mkcl sbcl) (with-current-directory (directory))
              #+(or allegro clasp clisp ecl lispworks mkcl) (multiple-value-list)
470
              (apply
471
472
473
               #+allegro 'excl:run-shell-command
               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
               #+(and allegro os-windows) %command
474
               #+clisp
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
               (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
               #+(or cmu ecl scl) 'ext:run-program
               #+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
                #+(or clozure cmu ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
                `(: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))
                #+(or clozure cmu ecl lispworks mkcl sbcl scl)
                `(:if-input-does-not-exist ,if-input-does-not-exist
                  :if-output-exists ,if-output-exists
                  #-lispworks :if-error-exists #+lispworks :if-error-output-exists
                  ,if-error-output-exists)
                #+lispworks `(:save-exit-status t)
                #+sbcl `(:search t
                         :if-output-does-not-exist :create
                         :if-error-does-not-exist :create)
                #+mkcl `(:directory ,(native-namestring directory))
                #-sbcl keys
                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
           (process-info-r ())))
     (flet ((prop (key value) (push key process-info-r) (push value process-info-r)))
       #+allegro
       (cond
         (wait (prop :exit-code (first process*)))
         (separate-streams
          (destructuring-bind (in out err pid) process*
            (prop :process pid)
            (when (eq input :stream) (prop :input-stream in))
            (when (eq output :stream) (prop :output-stream out))
            (when (eq error-output :stream) (prop :error-stream err))))
         (t
          (prop :process (third process*))
          (let ((x (first process*)))
            (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
              (0)
              (1 (prop :input-stream x))
              (2 (prop :output-stream x))
              (3 (prop :bidir-stream x))))
523
          (when (eq error-output :stream)
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
            (prop :error-stream (second process*)))))
       #+clisp
       (cond
         (wait (prop :exit-code (clisp-exit-code (first process*))))
         (t
          (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
            (0)
            (1 (prop :input-stream (first process*)))
            (2 (prop :output-stream (first process*)))
            (3 (prop :bidir-stream (pop process*))
             (prop :input-stream (pop process*))
             (prop :output-stream (pop process*))))))
       #+(or clozure cmu sbcl scl)
       (progn
         (prop :process process*)
         (when (eq input :stream)
           (prop :input-stream
                 #+clozure (ccl:external-process-input-stream process*)
                 #+(or cmu scl) (ext:process-input process*)
                 #+sbcl (sb-ext:process-input process*)))
         (when (eq output :stream)
           (prop :output-stream
                 #+clozure (ccl:external-process-output-stream process*)
                 #+(or cmu scl) (ext:process-output process*)
                 #+sbcl (sb-ext:process-output process*)))
         (when (eq error-output :stream)
           (prop :error-output-stream
                 #+clozure (ccl:external-process-error-stream process*)
                 #+(or cmu scl) (ext:process-error process*)
                 #+sbcl (sb-ext:process-error process*))))
       #+(or clasp ecl mkcl)
       (destructuring-bind #+(or clasp ecl) (stream code process) #+mkcl (stream process code) process*
         (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
           (cond
             ((zerop mode))
             ((null process*) (prop :exit-code -1))
             (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream))))
         (when code (prop :exit-code code))
         (when process (prop :process process)))
       #+lispworks
       (if wait
           (prop :exit-code (first process*))
           (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
             (if (zerop mode)
                 (prop :process (first process*))
                 (destructuring-bind (x err pid) process*
                   (prop :process pid)
                   (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x)
                   (when (eq error-output :stream) (prop :error-stream err))))))
       (nreverse process-info-r))))
574

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
575
576
577
578
579
  (defun %process-info-pid (process-info)
    (let ((process (getf process-info :process)))
      (declare (ignorable process))
      #+(or allegro lispworks) process
      #+clozure (ccl::external-process-pid process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
580
      #+(or clasp ecl) (si:external-process-pid process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
581
      #+(or cmu scl) (ext:process-pid process)
582
      #+mkcl (mkcl:process-id process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
583
      #+sbcl (sb-ext:process-pid process)
584
      #-(or allegro cmu mkcl sbcl scl) (error "~S not implemented" '%process-info-pid)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
585

586
587
588
589
590
  (defun %wait-process-result (process-info)
    (or (getf process-info :exit-code)
        (let ((process (getf process-info :process)))
          (when process
            ;; 1- wait
591
            #+clozure (ccl::external-process-wait process)
592
593
594
595
596
597
            #+(or cmu scl) (ext:process-wait process)
            #+sbcl (sb-ext:process-wait process)
            ;; 2- extract result
            #+allegro (sys:reap-os-subprocess :pid process :wait t)
            #+clozure (nth-value 1 (ccl:external-process-status process))
            #+(or cmu scl) (ext:process-exit-code process)
598
            #+(or clasp ecl) (nth-value 1 (ext:external-process-wait process t))
599
600
601
602
603
604
605
606
            #+lispworks
            (if-let ((stream (or (getf process-info :input-stream)
                                 (getf process-info :output-stream)
                                 (getf process-info :bidir-stream)
                                 (getf process-info :error-stream))))
              (system:pipe-exit-status stream :wait t)
              (if-let ((f (find-symbol* :pid-exit-status :system nil)))
                (funcall f process :wait t)))
607
608
            #+sbcl (sb-ext:process-exit-code process)
            #+mkcl (mkcl:join-process process)))))
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624

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

  (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
                                &key element-type external-format &allow-other-keys)
    ;; handle redirection for run-program and system
    ;; SPEC is the specification for the subprocess's input or output or error-output
    ;; TVAL is the value used if the spec is T
    ;; GF is the generic function to call to handle arbitrary values of SPEC
    ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
    ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
625
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
626
627
628
629
630
631
632
    ;; 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))
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
    (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)
649
                     (with-temporary-file (:pathname tmp)
650
651
                       (ecase direction
                         (:input
652
653
654
655
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
656
657
                          (funcall fun tmp nil))
                         ((:output :error-output)
658
659
660
661
662
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
663
664
665
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
666
          #+(or cmu (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
667
668
669
670
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
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

  (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)
703
            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
704
705
706

  (defun %use-run-program (command &rest keys
                           &key input output error-output ignore-error-status &allow-other-keys)
707
    ;; helper for RUN-PROGRAM when using %run-program
708
    #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl)
709
710
711
    (progn
      command keys input output error-output ignore-error-status ;; ignore
      (error "Not implemented on this platform"))
712
713
714
    (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))
715
           (active-error-output-p (%active-io-specifier-p error-output))
716
717
718
719
720
721
722
723
724
725
726
727
           (activity
             (cond
               (active-output-p :output)
               (active-input-p :input)
               (active-error-output-p :error-output)
               (t nil)))
           (wait (not activity))
           output-result error-output-result exit-code)
      (with-program-output ((reduced-output output-activity)
                            output :keys keys :setf output-result
                            :stream-easy-p t :active (eq activity :output))
        (with-program-error-output ((reduced-error-output error-output-activity)
728
                                    error-output :keys keys :setf error-output-result
729
730
731
732
733
                                    :stream-easy-p t :active (eq activity :error-output))
          (with-program-input ((reduced-input input-activity)
                               input :keys keys
                               :stream-easy-p t :active (eq activity :input))
            (let ((process-info
734
735
736
                    (apply '%run-program command
                           :wait wait :input reduced-input :output reduced-output
                           :error-output (if (eq error-output :output) :output reduced-error-output)
737
                           keys)))
738
739
740
741
742
743
744
745
746
747
              (labels ((get-stream (stream-name &optional fallbackp)
                         (or (getf process-info stream-name)
                             (when fallbackp
                               (getf process-info :bidir-stream))))
                       (run-activity (activity stream-name &optional fallbackp)
                         (if-let (stream (get-stream stream-name fallbackp))
                           (funcall activity stream)
                           (error 'subprocess-error
                                  :code `(:missing ,stream-name)
                                  :command command :process process-info))))
748
749
750
                (unwind-protect
                     (ecase activity
                       ((nil))
751
752
                       (:input (run-activity input-activity :input-stream t))
                       (:output (run-activity output-activity :output-stream t))
753
754
755
756
757
758
759
760
761
                       (:error-output (run-activity error-output-activity :error-output-stream)))
                  (loop :for (() val) :on process-info :by #'cddr
                        :when (streamp val) :do (ignore-errors (close val)))
                  (setf exit-code
                        (%check-result (%wait-process-result process-info)
                                       :command command :process process-info
                                       :ignore-error-status ignore-error-status))))))))
      (values output-result error-output-result exit-code)))

762
  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
763
    (etypecase command
764
765
766
      (string
       (os-cond
        ((os-windows-p)
767
768
769
         #+(or allegro clisp)
         (strcat (%cmd-shell-pathname) " /c " command)
         #-(or allegro clisp) command)
770
        (t command)))
771
      (list (escape-shell-command
772
773
             (os-cond
              ((os-unix-p) (cons "exec" command))
774
775
776
777
              ((os-windows-p)
               #+(or allegro sbcl clisp)
               (cons (%cmd-shell-pathname) (cons "/c" command))
               #-(or allegro sbcl clisp) command)
778
              (t command))))))
779

780
  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
781
782
783
784
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
785
                       (string (parse-native-namestring spec))
786
787
                       (pathname spec)
                       ((eql :output)
788
                        (assert (equal operator " 2>"))
789
790
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
791
                 (list operator " "
792
                       (escape-shell-token (native-namestring pathname)))))))
793
794
      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
             (normalized (%normalize-system-command command))
795
             (directory (or directory #+(or abcl xcl) (getcwd)))
796
797
798
799
800
             (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 " & ")))))))
801
        (reduce/strcat
802
803
         (os-cond
          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
804
          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
805

806
807
808
  (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()."
809
810
811
    (declare (ignorable input output error-output directory keys))
    #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
    (%wait-process-result
812
     (apply '%run-program (%normalize-system-command command) :wait t keys))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
813
    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
814
815
816
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
817
818
819
820
821
      #+clisp
      (%wait-process-result
       (apply '%run-program %command :wait t
              :input :interactive :output :interactive :error-output :interactive keys))
      #-(or clisp (and lispworks os-windows))
822
      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
823
        #+abcl (ext:run-shell-command %command)
824
        #+cormanlisp (win32:system %command)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
825
        #+(or clasp ecl) (let ((*standard-input* *stdin*)
826
827
828
                    (*standard-output* *stdout*)
                    (*error-output* *stderr*))
                (ext:system %command))
829
        #+gcl (system:system %command)
830
831
        #+genera (error "~S not supported on Genera, cannot run ~S"
                        '%system %command)
832
        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
833
        #+mkcl (mkcl:system %command)
834
        #+xcl (system:%run-shell-command %command))))
835
836
837

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
838
    ;; helper for RUN-PROGRAM when using %system
839
840
841
842
843
844
845
    (let (output-result error-output-result exit-code)
      (with-program-output ((reduced-output)
                            output :keys keys :setf output-result)
        (with-program-error-output ((reduced-error-output)
                                    error-output :keys keys :setf error-output-result)
          (with-program-input ((reduced-input) input :keys keys)
            (setf exit-code
846
                  (%check-result (apply '%system command
847
848
849
850
851
852
853
                                        :input reduced-input :output reduced-output
                                        :error-output reduced-error-output keys)
                                 :command command
                                 :ignore-error-status ignore-error-status)))))
      (values output-result error-output-result exit-code)))

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

865
Always call a shell (rather than directly execute the command when possible)
866
867
if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
specified to be NIL.
868

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

872
873
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.
874
875
876
877
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.
878
Otherwise, OUTPUT should be a value that is a suitable first argument to
879
SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
880
881
In this case, RUN-PROGRAM will create a temporary stream for the program output;
the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
882
883
884
885
using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
The primary value resulting from that call (or NIL if no call was needed)
will be the first value returned by RUN-PROGRAM.
E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
886
887
And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
stripped of any ending newline.
888
889
890

ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
891
892
Also :OUTPUT means redirecting the error output to the output stream,
in which case NIL is returned.
893
894
895
896

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

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

One and only one of the stream slurping or vomiting may or may not happen
901
902
903
904
905
in parallel in parallel with the subprocess,
depending on options and implementation,
and with priority being given to output processing.
Other streams are completely produced or consumed
before or after the subprocess is spawned, using temporary files.
906
907
908
909
910
911
912

RUN-PROGRAM returns 3 values:
0- the result of the OUTPUT slurping if any, or NIL
1- the result of the ERROR-OUTPUT slurping if any, or NIL
2- either 0 if the subprocess exited with success status,
or an indication of failure via the EXIT-CODE of the process"
    (declare (ignorable ignore-error-status))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
913
    #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
914
    (error "RUN-PROGRAM not implemented for this Lisp")
915
916
917
918
919
    ;; per doc string, set FORCE-SHELL to T if we get command as a string.  But
    ;; don't override user's specified preference. [2015/06/29:rpg]
    (when (stringp command)
      (unless force-shell-suppliedp
        (setf force-shell t)))
920
921
    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
      (apply (if (or force-shell
922
                     #+(or clasp clisp) (or (not ignore-error-status) t)
923
                     #+clisp (member error-output '(:interactive :output))
924
925
                     ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
                     #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
926
                               (lexicographic<= '< ver '(16 0 1)))
927
                     #+(and lispworks os-unix) (%interactivep input output error-output)
928
                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
929
930
931
932
933
934
935
936
                 '%use-system '%use-run-program)
             command
             :input (default input inputp output)
             :error-output (default error-output error-output-p output)
             :if-input-does-not-exist if-input-does-not-exist
             :if-output-exists if-output-exists
             :if-error-output-exists if-error-output-exists
             :element-type element-type :external-format external-format
937
             keys))))