run-program.lisp 44.9 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 34 35 36 37 38 39 40 41 42 43 44 45 46
    (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
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 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))))))

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

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

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

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

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

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

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


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

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

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

174
  #-genera
175
  (defmethod slurp-input-stream ((function function) input-stream &key)
176 177
    (funcall function input-stream))

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

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

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

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

194
  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
195 196
    (slurp-stream-lines stream :count count))

197
  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
198 199
    (slurp-stream-line stream :at at))

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

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

206 207 208
  (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
209
  (defmethod slurp-input-stream ((x null) (stream t) &key)
210 211
    nil)

212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
  (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)))

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

243

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

263
  #-genera
264
  (defmethod vomit-output-stream ((function function) output-stream &key)
265 266
    (funcall function output-stream))

267
  (defmethod vomit-output-stream ((list cons) output-stream &key)
268 269
    (apply (first list) output-stream (rest list)))

270
  #-genera
271
  (defmethod vomit-output-stream ((input-stream stream) output-stream
272
                                 &key linewise prefix (element-type 'character) buffer-size)
273 274 275 276
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

277
  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
278 279 280 281 282 283 284 285
    (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))

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


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

335 336 337 338 339 340 341 342 343
  ;;; 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."))))

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

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

  (defun %normalize-io-specifier (specifier &optional role)
379 380
    "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent
argument to pass to the internal RUN-PROGRAM"
381 382 383
    (declare (ignorable role))
    (etypecase specifier
      (null (or #+(or allegro lispworks) (null-device-pathname)))
384
      (string (parse-native-namestring specifier))
385 386 387 388 389 390
      (pathname specifier)
      (stream specifier)
      ((eql :stream) :stream)
      ((eql :interactive)
       #+allegro nil
       #+clisp :terminal
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
391 392
       #+(or clasp clozure cmu ecl mkcl sbcl scl) t)
      #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl)
393 394 395 396 397 398 399 400 401 402 403 404 405 406 407
      ((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)))

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

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
560 561 562 563 564
  (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
565
      #+(or clasp ecl) (si:external-process-pid process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
566
      #+(or cmu scl) (ext:process-pid process)
567
      #+mkcl (mkcl:process-id process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
568
      #+sbcl (sb-ext:process-pid process)
569
      #-(or allegro cmu mkcl sbcl scl) (error "~S not implemented" '%process-info-pid)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
570

571 572 573 574 575
  (defun %wait-process-result (process-info)
    (or (getf process-info :exit-code)
        (let ((process (getf process-info :process)))
          (when process
            ;; 1- wait
576
            #+clozure (ccl::external-process-wait process)
577
            #+(or cmu scl) (ext:process-wait process)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
578
            #+(and (or clasp ecl) os-unix) (ext:external-process-wait process)
579 580 581 582 583
            #+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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
584
            #+(or clasp ecl) (nth-value 1 (ext:external-process-status process))
585 586 587 588 589 590 591 592
            #+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)))
593 594
            #+sbcl (sb-ext:process-exit-code process)
            #+mkcl (mkcl:join-process process)))))
595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610

  (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)
611
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
612 613 614 615 616 617 618
    ;; 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))
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634
    (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)
635
                     (with-temporary-file (:pathname tmp)
636 637
                       (ecase direction
                         (:input
638 639 640 641
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
642 643
                          (funcall fun tmp nil))
                         ((:output :error-output)
644 645 646 647 648
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
649 650 651
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
652
          #+(or cmu (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
653 654 655 656
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688

  (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)
689
            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
690 691 692

  (defun %use-run-program (command &rest keys
                           &key input output error-output ignore-error-status &allow-other-keys)
693
    ;; helper for RUN-PROGRAM when using %run-program
694
    #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl)
695 696 697
    (progn
      command keys input output error-output ignore-error-status ;; ignore
      (error "Not implemented on this platform"))
698 699 700
    (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))
701
           (active-error-output-p (%active-io-specifier-p error-output))
702 703 704 705 706 707 708 709 710 711 712 713
           (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)
714
                                    error-output :keys keys :setf error-output-result
715 716 717 718 719
                                    :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
720 721 722
                    (apply '%run-program command
                           :wait wait :input reduced-input :output reduced-output
                           :error-output (if (eq error-output :output) :output reduced-error-output)
723
                           keys)))
724 725 726 727 728 729 730 731 732 733
              (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))))
734 735 736
                (unwind-protect
                     (ecase activity
                       ((nil))
737 738
                       (:input (run-activity input-activity :input-stream t))
                       (:output (run-activity output-activity :output-stream t))
739 740 741 742 743 744 745 746 747
                       (: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)))

748
  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
749
    (etypecase command
750 751 752
      (string
       (os-cond
        ((os-windows-p)
753 754 755
         #+(or allegro clisp)
         (strcat (%cmd-shell-pathname) " /c " command)
         #-(or allegro clisp) command)
756
        (t command)))
757
      (list (escape-shell-command
758 759
             (os-cond
              ((os-unix-p) (cons "exec" command))
760 761 762 763
              ((os-windows-p)
               #+(or allegro sbcl clisp)
               (cons (%cmd-shell-pathname) (cons "/c" command))
               #-(or allegro sbcl clisp) command)
764
              (t command))))))
765

766
  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
767 768 769 770
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
771
                       (string (parse-native-namestring spec))
772 773
                       (pathname spec)
                       ((eql :output)
774
                        (assert (equal operator " 2>"))
775 776
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
777
                 (list operator " "
778
                       (escape-shell-token (native-namestring pathname)))))))
779 780
      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
             (normalized (%normalize-system-command command))
781
             (directory (or directory #+(or abcl xcl) (getcwd)))
782 783 784 785 786
             (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 " & ")))))))
787
        (reduce/strcat
788 789
         (os-cond
          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
790
          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
791

792 793 794
  (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()."
795 796 797
    (declare (ignorable input output error-output directory keys))
    #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
    (%wait-process-result
798
     (apply '%run-program (%normalize-system-command command) :wait t keys))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
799
    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
800 801 802
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
803 804 805 806 807
      #+clisp
      (%wait-process-result
       (apply '%run-program %command :wait t
              :input :interactive :output :interactive :error-output :interactive keys))
      #-(or clisp (and lispworks os-windows))
808
      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
809
        #+abcl (ext:run-shell-command %command)
810
        #+cormanlisp (win32:system %command)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
811
        #+(or clasp ecl) (let ((*standard-input* *stdin*)
812 813 814
                    (*standard-output* *stdout*)
                    (*error-output* *stderr*))
                (ext:system %command))
815
        #+gcl (system:system %command)
816 817
        #+genera (error "~S not supported on Genera, cannot run ~S"
                        '%system %command)
818
        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
819
        #+mkcl (mkcl:system %command)
820
        #+xcl (system:%run-shell-command %command))))
821 822 823

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
824
    ;; helper for RUN-PROGRAM when using %system
825 826 827 828 829 830 831
    (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
832
                  (%check-result (apply '%system command
833 834 835 836 837 838 839
                                        :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
840
                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
841 842 843 844 845 846
                         (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)
847
    "Run program specified by COMMAND,
848
either a list of strings specifying a program and list of arguments,
849 850
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).

851
Always call a shell (rather than directly execute the command when possible)
852 853
if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
specified to be NIL.
854

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

858 859
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.
860 861 862 863
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.
864
Otherwise, OUTPUT should be a value that is a suitable first argument to
865
SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
866 867
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,
868 869 870 871
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.
872 873
And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
stripped of any ending newline.
874 875 876

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*.
877 878
Also :OUTPUT means redirecting the error output to the output stream,
in which case NIL is returned.
879 880 881 882

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

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

One and only one of the stream slurping or vomiting may or may not happen
887 888 889 890 891
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.
892 893 894 895 896 897 898

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
899
    #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
900
    (error "RUN-PROGRAM not implemented for this Lisp")
901 902 903 904 905
    ;; 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)))
906 907
    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
      (apply (if (or force-shell
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
908
                     #+(or clasp clisp ecl) (or (not ignore-error-status) t)
909
                     #+clisp (member error-output '(:interactive :output))
910
                     #+(and lispworks os-unix) (%interactivep input output error-output)
911
                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
912 913 914 915 916 917 918 919 920
                 '%use-system '%use-run-program)
             command
             :input (default input inputp output)
             :error-output (default error-output error-output-p output)
             :if-input-does-not-exist if-input-does-not-exist
             :if-output-exists if-output-exists
             :if-error-output-exists if-error-output-exists
             :element-type element-type :external-format external-format
           keys))))