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

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

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

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

24
25
26
(with-upgradability ()
  (defun requires-escaping-p (token &key good-chars bad-chars)
    "Does this token require escaping, given the specification of
27
28
either good chars that don't need escaping or bad chars that do need escaping,
as either a recognizing function or a sequence of characters."
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
    (some
     (cond
       ((and good-chars bad-chars)
        (error "only one of good-chars and bad-chars can be provided"))
       ((functionp good-chars)
        (complement good-chars))
       ((functionp bad-chars)
        bad-chars)
       ((and good-chars (typep good-chars 'sequence))
        #'(lambda (c) (not (find c good-chars))))
       ((and bad-chars (typep bad-chars 'sequence))
        #'(lambda (c) (find c bad-chars)))
       (t (error "requires-escaping-p: no good-char criterion")))
     token))

  (defun escape-token (token &key stream quote good-chars bad-chars escaper)
    "Call the ESCAPER function on TOKEN string if it needs escaping as per
46
47
REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
using STREAM as output (or returning result as a string if NIL)"
48
49
50
51
    (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
        (with-output (stream)
          (apply escaper token stream (when quote `(:quote ,quote))))
        (output-string token stream)))
52

53
54
  (defun escape-windows-token-within-double-quotes (x &optional s)
    "Escape a string token X within double-quotes
55
for use within a MS Windows command-line, outputing to S."
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
    (labels ((issue (c) (princ c s))
             (issue-backslash (n) (loop :repeat n :do (issue #\\))))
      (loop
        :initially (issue #\") :finally (issue #\")
        :with l = (length x) :with i = 0
        :for i+1 = (1+ i) :while (< i l) :do
          (case (char x i)
            ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
            ((#\\)
             (let* ((j (and (< i+1 l) (position-if-not
                                       #'(lambda (c) (eql c #\\)) x :start i+1)))
                    (n (- (or j l) i)))
               (cond
                 ((null j)
                  (issue-backslash (* 2 n)) (setf i l))
                 ((and (< j l) (eql (char x j) #\"))
                  (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
                 (t
                  (issue-backslash n) (setf i j)))))
            (otherwise
             (issue (char x i)) (setf i i+1))))))

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

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

94
95
  (defun easy-sh-character-p (x)
    (or (alphanumericp x) (find x "+-_.,%@:/")))
96

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

  (defun escape-shell-token (token &optional s)
    (cond
      ((os-unix-p) (escape-sh-token token s))
      ((os-windows-p) (escape-windows-token token s))))

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

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

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


137
;;;; Slurping a stream, typically the output of another program
138
(with-upgradability ()
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
  (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys)
    (: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
* if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the 
  INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
    \(APPLY x <stream> y\)
* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream, 
  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.

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

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
  #-(or gcl2.6 genera)
  (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
    (funcall function input-stream))

  (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
    (apply (first list) (cons input-stream (rest list))))

  #-(or gcl2.6 genera)
  (defmethod slurp-input-stream ((output-stream stream) input-stream
                                 &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

  (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
    (declare (ignorable x))
    (slurp-stream-string stream))

  (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
    (declare (ignorable x))
    (slurp-stream-string stream))

  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
    (declare (ignorable x))
    (slurp-stream-lines stream :count count))

  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
    (declare (ignorable x))
    (slurp-stream-line stream :at at))

  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
    (declare (ignorable x))
    (slurp-stream-forms stream :count count))

  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
    (declare (ignorable x))
    (slurp-stream-form stream :at at))

200
201
202
203
  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    (declare (ignorable x))
    (apply 'slurp-input-stream *standard-output* stream keys))

204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
  (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)))

221
222
223
224
225
226
227
228
229
230
231
232
233
234
  (defmethod slurp-input-stream (x stream
                                 &key linewise prefix (element-type 'character) buffer-size
                                 &allow-other-keys)
    (declare (ignorable stream linewise prefix element-type buffer-size))
    (cond
      #+(or gcl2.6 genera)
      ((functionp x) (funcall x stream))
      #+(or gcl2.6 genera)
      ((output-stream-p x)
       (copy-stream-to-stream
        input-stream output-stream
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
       (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
235

236
237
238
239

;;;; ----- Running an external program -----
;;; Simple variant of run-program with no input, and capturing output
;;; On some implementations, may output to a temporary file...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
(with-upgradability ()
  (define-condition subprocess-error (error)
    ((code :initform nil :initarg :code :reader subprocess-error-code)
     (command :initform nil :initarg :command :reader subprocess-error-command)
     (process :initform nil :initarg :process :reader subprocess-error-process))
    (:report (lambda (condition stream)
               (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
                       (subprocess-error-process condition)
                       (subprocess-error-command condition)
                       (subprocess-error-code condition)))))

  (defun run-program (command
                       &key output ignore-error-status force-shell
                       (element-type *default-stream-element-type*)
                       (external-format :default)
                       &allow-other-keys)
    "Run program specified by COMMAND,
257
either a list of strings specifying a program and list of arguments,
258
259
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).

260
261
Always call a shell (rather than directly execute the command)
if FORCE-SHELL is specified.
262
263
264
265
266
267
268
269
270

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

If OUTPUT is either NIL or :INTERACTIVE, then
return the exit status code of the process that was called.
if it was NIL, the output is discarded;
if it was :INTERACTIVE, the output and the input are inherited from the current process.

271
Otherwise, OUTPUT should be a value that is a suitable first argument to
272
SLURP-INPUT-STREAM (qv.).  In this case, RUN-PROGRAM will create a temporary stream
273
for the program output.  The program output, in that stream, will be processed
274
275
276
277
by SLURP-INPUT-STREAM, using OUTPUT as the first argument.  RUN-PROGRAM will
return whatever SLURP-INPUT-STREAM returns.  E.g., using :OUTPUT :STRING will
have it return the entire output stream as a string.  Use ELEMENT-TYPE and
EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
278
279
280
281
282
283
284
285
286

    ;; TODO: The current version does not honor :OUTPUT NIL on Allegro.  Setting
    ;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do
    ;; what :OUTPUT :INTERACTIVE is advertised to do here.  To get the behavior
    ;; specified for :OUTPUT NIL, one would have to grab up the process output
    ;; into a stream and then throw it on the floor.  The consequences of
    ;; getting this wrong seemed so much worse than having excess output that it
    ;; is not currently implemented.

287
    ;; TODO: specially recognize :output pathname ?
288
289
290
291
292
293
    (declare (ignorable ignore-error-status element-type external-format))
    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
    (error "RUN-PROGRAM not implemented for this Lisp")
    (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
             (run-program (command &key pipe interactive)
               "runs the specified command (a list of program and arguments).
294
295
296
              If using a pipe, returns two values: process and stream
              If not using a pipe, returns one values: the process result;
              also, inherits the output stream."
297
298
299
300
301
               ;; NB: these implementations have unix vs windows set at compile-time.
               (assert (not (and pipe interactive)))
               (let* ((wait (not pipe))
                      #-(and clisp os-windows)
                      (command
302
                        (etypecase command
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
                          #+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.
                           #+allegro command
                           ;; On ClozureCL for Windows, we assume you are using
                           ;; r15398 or later in 1.9 or later,
                           ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
                           #+clozure (cons "cmd" (strcat "/c " command))
                           ;; NB: On other Windows implementations, this is utterly bogus
                           ;; except in the most trivial cases where no quoting is needed.
                           ;; Use at your own risk.
                           #-(or allegro clozure) (list "cmd" "/c" command))
                          #+os-windows
                          (list
319
320
                           #+allegro (escape-windows-command command)
                           #-allegro command)))
321
322
323
324
325
326
                      (process*
                        (multiple-value-list
                         #+allegro
                         (excl:run-shell-command
                          #+os-unix (coerce (cons (first command) command) 'vector)
                          #+os-windows command
327
328
                          :input nil
                          :output (and pipe :stream) :wait wait
329
                          #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
330
331
332
333
334
335
336
337
338
                         #+clisp
                         (flet ((run (f &rest args)
                                  (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
                                                    ,(if pipe :stream :terminal)))))
                           (etypecase command
                             #+os-windows (run 'ext:run-shell-command command)
                             (list (run 'ext:run-program (car command)
                                        :arguments (cdr command)))))
                         #+lispworks
339
340
                         (if interactive
                             (system:call-system-showing-output
341
                              #+os-unix
342
                              (cons "/usr/bin/env" command) ; lispworks wants a full path.
343
344
                              #-os-unix
                              command
345
346
347
348
349
350
                              :show-cmd nil
                              :wait wait)
                           (system:run-shell-command
                            (cons "/usr/bin/env" command) ; lispworks wants a full path.
                            :input nil :output (and pipe :stream)
                            :wait wait :save-exit-status (and pipe t)))
351
352
353
354
355
356
357
358
359
360
361
362
                         #+(or clozure cmu ecl sbcl scl)
                         (#+(or cmu ecl scl) ext:run-program
                            #+clozure ccl:run-program
                            #+sbcl sb-ext:run-program
                            (car command) (cdr command)
                            :input interactive :wait wait
                            :output (if pipe :stream t)
                            . #.(append
                                 #+(or clozure cmu ecl sbcl scl) '(:error t)
                                 ;; note: :external-format requires a recent SBCL
                                 #+sbcl '(:search t :external-format external-format)))))
                      (process
363
                        #+allegro (if pipe (third process*) (first process*))
364
                        #+ecl (third process*)
365
                        #-(or allegro ecl) (first process*))
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
                      (stream
                        (when pipe
                          #+(or allegro lispworks ecl) (first process*)
                          #+clisp (first process*)
                          #+clozure (ccl::external-process-output process)
                          #+(or cmu scl) (ext:process-output process)
                          #+sbcl (sb-ext:process-output process))))
                 (values process stream)))
             #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
             (process-result (process pipe)
               (declare (ignorable pipe))
               ;; 1- wait
               #+(and clozure os-unix) (ccl::external-process-wait process)
               #+(or cmu scl) (ext:process-wait process)
               #+(and ecl os-unix) (ext:external-process-wait process)
               #+sbcl (sb-ext:process-wait process)
               ;; 2- extract result
               #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
               #+clisp process
               #+clozure (nth-value 1 (ccl:external-process-status process))
               #+(or cmu scl) (ext:process-exit-code process)
               #+ecl (nth-value 1 (ext:external-process-status process))
388
               #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
               #+sbcl (sb-ext:process-exit-code process))
             (check-result (exit-code process)
               #+clisp
               (setf exit-code
                     (typecase exit-code (integer exit-code) (null 0) (t -1)))
               (unless (or ignore-error-status
                           (equal exit-code 0))
                 (error 'subprocess-error :command command :code exit-code :process process))
               exit-code)
             (use-run-program ()
               #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
               (let* ((interactive (eq output :interactive))
                      (pipe (and output (not interactive))))
                 (multiple-value-bind (process stream)
                     (run-program command :pipe pipe :interactive interactive)
                   (if (and output (not interactive))
                       (unwind-protect
                            (slurp-input-stream output stream)
                         (when stream (close stream))
                         (check-result (process-result process pipe) process))
                       (unwind-protect
                            (check-result
                             #+(or allegro lispworks) ; when not capturing, returns the exit code!
                             process
                             #-(or allegro lispworks) (process-result process pipe)
                             process))))))
             (system-command (command)
               (etypecase command
417
                 (string command)
418
419
420
421
422
423
424
425
426
                 (list (escape-shell-command
                        (if (os-unix-p) (cons "exec" command) command)))))
             (redirected-system-command (command out)
               (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
                       (system-command command) (native-namestring out)))
             (system (command &key interactive)
               (declare (ignorable interactive))
               #+(or abcl xcl) (ext:run-shell-command command)
               #+allegro
427
               (excl:run-shell-command
428
                command
429
                :input nil
430
431
432
433
                :output nil
                :error-output :output ; write STDERR to output, too
                :wait t
                #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
434
435
436
437
438
439
440
               #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
               (process-result (run-program command :pipe nil :interactive interactive) nil)
               #+ecl (ext:system command)
               #+cormanlisp (win32:system command)
               #+gcl (lisp:system command)
               #+(and lispworks os-windows)
               (system:call-system-showing-output
441
                command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
442
443
444
445
446
447
448
449
450
               #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
               #+mkcl (nth-value 2
                                 (mkcl:run-program #+windows command #+windows ()
                                                   #-windows "/bin/sh" (list "-c" command)
                                                   :input nil :output nil)))
             (call-system (command-string &key interactive)
               (check-result (system command-string :interactive interactive) nil))
             (use-system ()
               (let ((interactive (eq output :interactive)))
451
                 (if (and output (not interactive))
452
453
454
455
456
457
458
459
460
461
462
463
464
465
                     (with-temporary-file (:pathname tmp :direction :output)
                       (call-system (redirected-system-command command tmp))
                       (with-open-file (stream tmp
                                               :direction :input
                                               :if-does-not-exist :error
                                               :element-type element-type
                                               #-gcl2.6 :external-format #-gcl2.6 external-format)
                         (slurp-input-stream output stream)))
                     (call-system (system-command command) :interactive interactive)))))
      (if (and (not force-shell)
               #+(or clisp ecl) ignore-error-status
               #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
          (use-run-program)
          (use-system)))))
466