run-program.lisp 41.2 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 #:vomit-output-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
    (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
101 102 103 104 105 106 107 108 109 110
                        :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
111
spaced, escaped tokens, using ESCAPER to escape."
112 113 114 115 116 117 118 119 120
    (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
121 122 123
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
124
    (escape-command command s 'escape-windows-token))
125

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

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


136
;;;; Slurping a stream, typically the output of another program
137
(with-upgradability ()
138 139 140 141 142
  (defun call-stream-processor (fun processor stream)
    (if (consp processor)
        (apply fun (first processor) stream (rest processor))
        (funcall fun processor stream)))

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

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

167
  #-(or gcl2.6 genera)
168
  (defmethod slurp-input-stream ((function function) input-stream &key)
169 170
    (funcall function input-stream))

171
  (defmethod slurp-input-stream ((list cons) input-stream &key)
172
    (apply (first list) input-stream (rest list)))
173 174 175

  #-(or gcl2.6 genera)
  (defmethod slurp-input-stream ((output-stream stream) input-stream
176
                                 &key linewise prefix (element-type 'character) buffer-size)
177 178 179 180
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

181
  (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
182
    (declare (ignorable x))
183
    (slurp-stream-string stream :stripped stripped))
184

185
  (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
186
    (declare (ignorable x))
187
    (slurp-stream-string stream :stripped stripped))
188

189
  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
190 191 192
    (declare (ignorable x))
    (slurp-stream-lines stream :count count))

193
  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
194 195 196
    (declare (ignorable x))
    (slurp-stream-line stream :at at))

197
  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
198 199 200
    (declare (ignorable x))
    (slurp-stream-forms stream :count count))

201
  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
202 203 204
    (declare (ignorable x))
    (slurp-stream-form stream :at at))

205 206 207 208
  (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))

209 210
  (defmethod slurp-input-stream ((x null) stream &key)
    (declare (ignorable x stream))
211 212
    nil)

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

230
  (defmethod slurp-input-stream (x stream
231
                                 &key linewise prefix (element-type 'character) buffer-size)
232 233 234 235 236 237 238
    (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
239
        stream x
240 241 242
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
       (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
243

244

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

  #-(or gcl2.6 genera)
265
  (defmethod vomit-output-stream ((function function) output-stream &key)
266 267
    (funcall function output-stream))

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

  #-(or gcl2.6 genera)
  (defmethod vomit-output-stream ((input-stream stream) output-stream
273
                                 &key linewise prefix (element-type 'character) buffer-size)
274 275 276 277
    (copy-stream-to-stream
     input-stream output-stream
     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))

278
  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
279 280 281 282 283 284 285 286 287
    (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)
    (declare (ignorable x))
    (apply 'vomit-output-stream *standard-input* stream keys))

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


324 325 326
;;;; ----- Running an external program -----
;;; Simple variant of run-program with no input, and capturing output
;;; On some implementations, may output to a temporary file...
327 328 329 330 331 332 333 334 335 336 337
(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)))))

338 339
  ;;; Internal helpers for run-program
  (defun %normalize-command (command)
340 341
    "Given a COMMAND as a list or string, transform it in a format suitable
for the implementation's underlying run-program function"
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
    (etypecase command
      #+os-unix (string `("/bin/sh" "-c" ,command))
      #+os-unix (list command)
      #+os-windows
      (string
       ;; NB: We do NOT add cmd /c here. You might want to.
       #+(or allegro clisp) command
       ;; On ClozureCL for Windows, we assume you are using
       ;; r15398 or later in 1.9 or later,
       ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
       #+clozure (cons "cmd" (strcat "/c " command))
       ;; 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 clisp clozure) (list "cmd" "/c" command))
      #+os-windows
      (list
       #+allegro (escape-windows-command command)
       #-allegro command)))

  (defun %active-io-specifier-p (specifier)
363 364 365 366 367 368
    "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."
    (not (typep specifier '(or null string pathname (eql :interactive)
                            #+(or cmu sbcl scl) stream
                            #+lispworks file-stream)))) ;; not a type!? comm:socket-stream
369 370

  (defun %normalize-io-specifier (specifier &optional role)
371 372
    "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent
argument to pass to the internal RUN-PROGRAM"
373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399
    (declare (ignorable role))
    (etypecase specifier
      (null (or #+(or allegro lispworks) (null-device-pathname)))
      (string (pathname specifier))
      (pathname specifier)
      (stream specifier)
      ((eql :stream) :stream)
      ((eql :interactive)
       #+allegro nil
       #+clisp :terminal
       #+(or clozure cmu ecl sbcl scl) t)
      #+(or allegro clozure cmu ecl lispworks sbcl scl)
      ((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)))

400 401 402 403 404 405 406 407 408 409 410 411 412
  (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:
413 414
     PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
    ;; NB: these implementations have unix vs windows set at compile-time.
415
    (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists))
416 417
    (assert (not (and wait (member :stream (list input output error-output)))))
    #-(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
418
    (progn command keys directory
419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
           (error "run-program not available"))
    #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl)
    (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))
           (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
             (with-current-directory (#-sbcl directory)
               #+clisp
               (flet ((run (f &rest args)
                        (multiple-value-list
                         (apply f :input %input :output %output
                                  :allow-other-keys t `(,@args ,@keys)))))
                 (assert (eq error-output :interactive))
446
                 ;;; since we now always return a code, we can't use this code path, anyway!
447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
                 (etypecase %command
                   #+os-windows (string (run 'ext:run-shell-command %command))
                   (list (run 'ext:run-program (car %command)
                              :arguments (cdr %command)))))
               #+(or clozure cmu ecl sbcl scl)
               (#-ecl progn #+ecl multiple-value-list
                (apply
                 '#+(or cmu ecl scl) ext:run-program
                 #+clozure ccl:run-program #+sbcl sb-ext:run-program
                 (car %command) (cdr %command)
                 :input %input
                 :output %output
                 :error %error-output
                 :wait wait
                 :allow-other-keys t
                 (append
                  #+(or clozure cmu sbcl scl)
                  `(: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
472 473 474 475 476 477 478 479
               (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))))
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 523 524 525 526 527 528 529
           (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*))))
530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548
        #+ecl
        (destructuring-bind (stream code process) 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))))))
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 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
        (nreverse process-info-r))))

  (defun %wait-process-result (process-info)
    (or (getf process-info :exit-code)
        (let ((process (getf process-info :process)))
          (when process
            ;; 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 (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)
            #+ecl (nth-value 1 (ext:external-process-status process))
            #+lispworks (system:pid-exit-status process :wait t)
            #+sbcl (sb-ext:process-exit-code process)))))

  (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)
    ;; DIRECTION is :INPUT or :OUTPUT for the direction of this io argument
    ;; 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))
    (when (eq spec t) (setf spec tval))
    (labels ((activity (stream)
               (call-function returner (call-stream-processor gf spec stream)))
             (easy-case ()
               (funcall fun spec nil))
             (hard-case ()
               (if activep
                   (funcall fun :stream #'activity)
                   (with-temporary-file (:pathname tmp :stream s
                                         :direction (ecase direction (:input :output) (:output :io))
                                         :element-type element-type
                                         :external-format external-format)
                     (ecase direction
                       (:input ;; for input
                        (unwind-protect (activity s)
                          (ignore-errors (close s)))
                        (funcall fun tmp nil))
                       (:output ;; for output, error-output
                        (unwind-protect
                             (multiple-value-prog1 (funcall fun tmp nil)
                               (activity s))
                          (ignore-errors (close s)))))))))
      (typecase spec
        ((or null string pathname (eql :interactive))
         (easy-case))
        #+(or cmu sbcl scl) ;; streams are only easy on implementations that try very hard
        (stream
         (if stream-easy-p (easy-case) (hard-case)))
        (t
         (hard-case)))))

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

  (defun %use-run-program (command &rest keys
                           &key input output error-output ignore-error-status &allow-other-keys)
    #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
    (error "Not implemented on this platform")
    (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))
662 663
           (active-error-output-p (or (eq error-output :output)
                                      (%active-io-specifier-p error-output)))
664 665 666 667 668 669 670 671 672 673 674 675
           (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)
676 677
                                    (unless (eq error-output :output) error-output)
                                    :keys keys :setf error-output-result
678 679 680 681 682
                                    :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
683 684 685
                    (apply '%run-program command
                           :wait wait :input reduced-input :output reduced-output
                           :error-output (if (eq error-output :output) :output reduced-error-output)
686
                           keys)))
687 688 689 690 691 692 693 694 695 696
              (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))))
697 698 699
                (unwind-protect
                     (ecase activity
                       ((nil))
700 701
                       (:input (run-activity input-activity :input-stream t))
                       (:output (run-activity output-activity :output-stream t))
702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740
                       (: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)))

  (defun %normalize-system-command (command)
    (etypecase command
      (string command)
      (list (escape-shell-command
             (if (os-unix-p) (cons "exec" command) command)))))

  (defun %redirected-system-command (command in out err directory)
    (flet ((redirect (spec operator)
             (let ((pathname
                     (typecase spec
                       (null (null-device-pathname))
                       (string (pathname spec))
                       (pathname spec)
                       ((eql :output)
                        (assert (equal operator "2>"))
                        (return-from redirect '(" 2>&1"))))))
               (when pathname
                 (list " " operator " "
                       (escape-shell-token (native-namestring pathname)))))))
      (multiple-value-bind (before after)
          (let ((normalized (%normalize-system-command command)))
            (if (os-unix-p)
                (values '("exec") (list " ; " normalized))
                (values (list normalized) ())))
        (reduce/strcat
         (append
          before (redirect in "<") (redirect out ">") (redirect err "2>")
          (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; "))
          after)))))

741 742 743
  (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()."
744 745 746
    (declare (ignorable input output error-output directory keys))
    #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
    (%wait-process-result
747
     (apply '%run-program (%normalize-system-command command) :wait t keys))
748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777
    #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl)
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
      #-(and lispworks os-windows)
      (with-current-directory ((unless (os-unix-p) directory))
        #+(or abcl xcl) (ext:run-shell-command %command)
        #+clisp (clisp-exit-code (ext:shell %command))
        #+cormanlisp (win32:system %command)
        #+ecl (let ((*standard-input* *stdin*)
                    (*standard-output* *stdout*)
                    (*error-output* *stderr*))
                (ext:system %command))
        #+gcl (lisp:system %command)
        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
        #+mkcl ;; PROBABLY BOGUS -- ask jcb
        (multiple-value-bind (io process exit-code)
            (mkcl:run-program #+windows %command #+windows ()
                              #-windows "/bin/sh" #-windows (list "-c" %command)
                              :input t :output t)))))

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
    (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
778
                  (%check-result (apply '%system command
779 780 781 782 783 784 785 786 787 788 789 790 791 792
                                        :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
                       &key ignore-error-status force-shell
                         (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)
793
    "Run program specified by COMMAND,
794
either a list of strings specifying a program and list of arguments,
795 796
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).

797
Always call a shell (rather than directly execute the command when possible)
798
if FORCE-SHELL is specified.
799

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

803 804 805
If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device,
the file at that path is used as output.
If it's :INTERACTIVE, output is inherited from the current process.
806
Otherwise, OUTPUT should be a value that is a suitable first argument to
807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835
SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
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,
using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
T designates the *STANDARD-OUTPUT* to be provided to SLURP-INPUT-STREAM.
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.

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*.
Also :OUTPUT means redirecting the error output to the output stream, and NIL is returned.

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

Use ELEMENT-TYPE and EXTERNAL-FORMAT to specify how streams are created.

One and only one of the stream slurping or vomiting may or may not happen
in parallel in parallel with the subprocess, depending on options and implementation.
Other streams are completely produced or consumed before or after the subprocess is spawned,
using temporary files.

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))
836 837
    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
    (error "RUN-PROGRAM not implemented for this Lisp")
838 839 840 841
    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
      (apply (if (or force-shell
                     #+(or clisp ecl) (or (not ignore-error-status) t)
                     #+clisp (eq error-output :interactive)
842
                     #+(and lispworks os-unix) (%interactivep input output error-output)
843 844 845 846 847 848 849 850 851 852
                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t)
                 '%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))))