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

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

14
   ;;; run-program
15
   #:slurp-input-stream #:vomit-output-stream
Elias Pipping's avatar
Elias Pipping committed
16 17
   #:close-streams #:launch-program #:process-alive-p #:run-program
   #:terminate-process #:wait-process
18
   #:process-info-error-output #:process-info-input #:process-info-output
Elias Pipping's avatar
Elias Pipping committed
19
   #:process-info-pid
20
   #:subprocess-error
21 22
   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
   ))
23
(in-package :uiop/run-program)
24 25 26

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

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

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

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

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

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

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

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

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

  (defun escape-shell-token (token &optional s)
112
    "Escape a token for the current operating system shell"
113
    (os-cond
114 115 116 117 118 119
      ((os-unix-p) (escape-sh-token token s))
      ((os-windows-p) (escape-windows-token token s))))

  (defun escape-command (command &optional s
                                  (escaper 'escape-shell-token))
    "Given a COMMAND as a list of tokens, return a string of the
120
spaced, escaped tokens, using ESCAPER to escape."
121 122 123 124 125 126 127 128 129
    (etypecase command
      (string (output-string command s))
      (list (with-output (s)
              (loop :for first = t :then nil :for token :in command :do
                (unless first (princ #\space s))
                (funcall escaper token s))))))

  (defun escape-windows-command (command &optional s)
    "Escape a list of command-line arguments into a string suitable for parsing
130 131 132
by CommandLineToArgv in MS Windows"
    ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
    ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
133
    (escape-command command s 'escape-windows-token))
134

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

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


145
;;;; Slurping a stream, typically the output of another program
146
(with-upgradability ()
147
  (defun call-stream-processor (fun processor stream)
148 149 150 151
    "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
a PROCESSOR specification which is either an atom or a list specifying
a processor an keyword arguments, call the specified processor with
the given STREAM as input"
152 153 154 155
    (if (consp processor)
        (apply fun (first processor) stream (rest processor))
        (funcall fun processor stream)))

156
  (defgeneric slurp-input-stream (processor input-stream &key)
157 158 159 160 161 162 163 164
    (:documentation
     "SLURP-INPUT-STREAM is a generic function with two positional arguments
PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
the contents of the INPUT-STREAM and processes them according to a method
specified by PROCESSOR.

Built-in methods include the following:
* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
165
* if PROCESSOR is a list, its first element should be a function.  It will be applied to a cons of the
166 167
  INPUT-STREAM and the rest of the list.  That is (x . y) will be treated as
    \(APPLY x <stream> y\)
168
* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
169 170 171 172 173 174 175
  per copy-stream-to-stream, with appropriate keyword arguments.
* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
  are returned as a string, as per SLURP-STREAM-STRING.
* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
176
* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
177 178

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

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

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

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

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

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

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

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

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

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

212 213 214
  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    (apply 'slurp-input-stream *standard-output* stream keys))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
215
  (defmethod slurp-input-stream ((x null) (stream t) &key)
216 217
    nil)

218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
  (defmethod slurp-input-stream ((pathname pathname) input
                                 &key
                                   (element-type *default-stream-element-type*)
                                   (external-format *utf-8-external-format*)
                                   (if-exists :rename-and-delete)
                                   (if-does-not-exist :create)
                                   buffer-size
                                   linewise)
    (with-output-file (output pathname
                              :element-type element-type
                              :external-format external-format
                              :if-exists if-exists
                              :if-does-not-exist if-does-not-exist)
      (copy-stream-to-stream
       input output
       :element-type element-type :buffer-size buffer-size :linewise linewise)))

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

249

250
(with-upgradability ()
251
  (defgeneric vomit-output-stream (processor output-stream &key)
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
    (:documentation
     "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.

Built-in methods include the following:
* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
* if PROCESSOR is a list, its first element should be a function.
  It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
  That is (x . y) will be treated as \(APPLY x <stream> y\)
* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
  per copy-stream-to-stream, with appropriate keyword arguments.
* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.

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

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

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

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

283
  (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
284 285 286 287 288 289 290 291
    (princ x stream)
    (when fresh-line (fresh-line stream))
    (when terpri (terpri stream))
    (values))

  (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    (apply 'vomit-output-stream *standard-input* stream keys))

292
  (defmethod vomit-output-stream ((x null) (stream t) &key)
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312
    (values))

  (defmethod vomit-output-stream ((pathname pathname) input
                                 &key
                                   (element-type *default-stream-element-type*)
                                   (external-format *utf-8-external-format*)
                                   (if-exists :rename-and-delete)
                                   (if-does-not-exist :create)
                                   buffer-size
                                   linewise)
    (with-output-file (output pathname
                              :element-type element-type
                              :external-format external-format
                              :if-exists if-exists
                              :if-does-not-exist if-does-not-exist)
      (copy-stream-to-stream
       input output
       :element-type element-type :buffer-size buffer-size :linewise linewise)))

  (defmethod vomit-output-stream (x stream
313
                                 &key linewise prefix (element-type 'character) buffer-size)
314 315
    (declare (ignorable stream linewise prefix element-type buffer-size))
    (cond
316
      #+genera
317
      ((functionp x) (funcall x stream))
318
      #+genera
319 320 321 322 323
      ((input-stream-p x)
       (copy-stream-to-stream
        x stream
        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
      (t
324
       (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
325 326


327 328 329
;;;; ----- Running an external program -----
;;; Simple variant of run-program with no input, and capturing output
;;; On some implementations, may output to a temporary file...
330 331 332 333 334 335
(with-upgradability ()
  (define-condition subprocess-error (error)
    ((code :initform nil :initarg :code :reader subprocess-error-code)
     (command :initform nil :initarg :command :reader subprocess-error-command)
     (process :initform nil :initarg :process :reader subprocess-error-process))
    (:report (lambda (condition stream)
336
               (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
337 338 339 340
                       (subprocess-error-process condition)
                       (subprocess-error-command condition)
                       (subprocess-error-code condition)))))

341 342 343 344 345 346 347 348 349
  ;;; find CMD.exe on windows
  (defun %cmd-shell-pathname ()
    (os-cond
     ((os-windows-p)
      (strcat (native-namestring (getenv-absolute-directory "WINDIR"))
              "System32\\cmd.exe"))
     (t
      (error "CMD.EXE is not the command shell for this OS."))))

350 351
  ;;; Internal helpers for run-program
  (defun %normalize-command (command)
352 353
    "Given a COMMAND as a list or string, transform it in a format suitable
for the implementation's underlying run-program function"
354 355 356 357 358 359 360 361 362 363 364
    (etypecase command
      #+os-unix (string `("/bin/sh" "-c" ,command))
      #+os-unix (list command)
      #+os-windows
      (string
       ;; NB: We do NOT add cmd /c here. You might want to.
       #+(or allegro clisp) command
       ;; On ClozureCL for Windows, we assume you are using
       ;; r15398 or later in 1.9 or later,
       ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
       #+clozure (cons "cmd" (strcat "/c " command))
Elias Pipping's avatar
Elias Pipping committed
365
       #+mkcl (list "cmd" "/c" command)
366
       #+sbcl (list (%cmd-shell-pathname) "/c" command)
367 368 369
       ;; NB: On other Windows implementations, this is utterly bogus
       ;; except in the most trivial cases where no quoting is needed.
       ;; Use at your own risk.
370
       #-(or allegro clisp clozure mkcl sbcl) (list "cmd" "/c" command))
371 372 373 374 375 376
      #+os-windows
      (list
       #+allegro (escape-windows-command command)
       #-allegro command)))

  (defun %active-io-specifier-p (specifier)
377 378 379
    "Determines whether a run-program I/O specifier requires Lisp-side processing
via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
or whether it's already taken care of by the implementation's underlying run-program."
380
    (not (typep specifier '(or null string pathname (member :interactive :output)
381
                            #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
Elias Pipping's avatar
Elias Pipping committed
382
                            #+lispworks file-stream))))
383 384

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

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

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

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

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

420 421 422 423 424 425
  (defclass process-info ()
    ((process :initform nil)
     (input-stream :initform nil)
     (output-stream :initform nil)
     (bidir-stream :initform nil)
     (error-output-stream :initform nil)
426 427 428 429 430 431 432
     ;; For backward-compatibility, to maintain the property (zerop
     ;; exit-code) <-> success, an exit in response to a signal is
     ;; encoded as 128+signum.
     (exit-code :initform nil)
     ;; If the platform allows it, distinguish exiting with a code
     ;; >128 from exiting in response to a signal by setting this code
     (signal-code :initform nil)))
433

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

If OUTPUT is a pathname, a string designating a pathname, or NIL
designating the null device, the file at that path is used as output.
If it's :INTERACTIVE, output is inherited from the current process;
beware that this may be different from your *STANDARD-OUTPUT*, and
under SLIME will be on your *inferior-lisp* buffer.  If it's T, output
goes to your current *STANDARD-OUTPUT* stream.  If it's :STREAM, a new
stream will be made available that can be accessed via
PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
that the underlying lisp implementation knows how to handle.

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

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

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

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

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

657 658 659 660 661 662 663 664 665
  (defun process-info-error-output (process-info)
    (slot-value process-info 'error-output-stream))
  (defun process-info-input (process-info)
    (or (slot-value process-info 'bidir-stream)
        (slot-value process-info 'input-stream)))
  (defun process-info-output (process-info)
    (or (slot-value process-info 'bidir-stream)
        (slot-value process-info 'output-stream)))

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

681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735
  (defun %process-status (process-info)
    (if-let (exit-code (slot-value process-info 'exit-code))
      (return-from %process-status
        (if-let (signal-code (slot-value process-info 'signal-code))
          (values :signaled signal-code)
          (values :exited exit-code))))
    #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl)
    (not-implemented-error '%process-status)
    (if-let (process (slot-value process-info 'process))
      (multiple-value-bind (status code)
          (progn
            #+allegro (multiple-value-bind (exit-code pid signal)
                          (sys:reap-os-subprocess :pid process :wait nil)
                        (assert pid)
                        (cond ((null exit-code) :running)
                              ((null signal) (values :exited exit-code))
                              (t (values :signaled signal))))
            #+clozure (ccl:external-process-status process)
            #+(or cmucl scl) (let ((status (ext:process-status process)))
                               (values status (if (member status '(:exited :signaled))
                                                  (ext:process-exit-code process))))
            #+ecl (ext:external-process-status process)
            #+lispworks
            ;; a signal is only returned on LispWorks 7+
            (multiple-value-bind (exit-code signal)
                (funcall #+lispworks7+ #'sys:pipe-exit-status
                         #-lispworks7+ #'sys:pid-exit-status
                         process :wait nil)
              (cond ((null exit-code) :running)
                    ((null signal) (values :exited exit-code))
                    (t (values :signaled signal))))
            #+mkcl (let ((status (mk-ext:process-status process))
                         (code (mk-ext:process-exit-code process)))
                     (if (stringp code)
                         (values :signaled (%mkcl-signal-to-number code))
                         (values status code)))
            #+sbcl (let ((status (sb-ext:process-status process)))
                     (values status (if (member status '(:exited :signaled))
                                        (sb-ext:process-exit-code process)))))
        (case status
          (:exited (setf (slot-value process-info 'exit-code) code))
          (:signaled (let ((%code (%signal-to-exit-code code)))
                       (setf (slot-value process-info 'exit-code) %code
                             (slot-value process-info 'signal-code) code))))
        (values status code))))

  (defun process-alive-p (process-info)
    "Check if a process has yet to exit."
    (unless (slot-value process-info 'exit-code)
      #+abcl (sys:process-alive-p (slot-value process-info 'process))
      #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
      #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
      #-(or abcl cmucl sbcl scl) (member (%process-status process-info)
                                         '(:running :sleeping))))

736 737 738 739
  (defun wait-process (process-info)
    "Wait for the process to terminate, if it is still running.
Otherwise, return immediately. An exit code (a number) will be
returned, with 0 indicating success, and anything else indicating
740 741 742
failure. If the process exits after receiving a signal, the exit code
will be the sum of 128 and the (positive) numeric signal code. A second
value may be returned in this case: the numeric signal code itself.
743 744 745
Any asynchronously spawned process requires this function to be run
before it is garbage-collected in order to free up resources that
might otherwise be irrevocably lost."
746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799
    (if-let (exit-code (slot-value process-info 'exit-code))
      (if-let (signal-code (slot-value process-info 'signal-code))
        (values exit-code signal-code)
        exit-code)
      (let ((process (slot-value process-info 'process)))
        #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
        (not-implemented-error 'wait-process)
        (when process
          ;; 1- wait
          #+clozure (ccl::external-process-wait process)
          #+(or cmucl scl) (ext:process-wait process)
          #+sbcl (sb-ext:process-wait process)
          ;; 2- extract result
          (multiple-value-bind (exit-code signal-code)
              (progn
                #+abcl (sys:process-wait process)
                #+allegro (multiple-value-bind (exit-code pid signal)
                              (sys:reap-os-subprocess :pid process :wait t)
                            (assert pid)
                            (values exit-code signal))
                #+clozure (multiple-value-bind (status code)
                              (ccl:external-process-status process)
                            (if (eq status :signaled)
                                (values nil code)
                                code))
                #+(or cmucl scl) (let ((status (ext:process-status process))
                                       (code (ext:process-exit-code process)))
                                   (if (eq status :signaled)
                                       (values nil code)
                                       code))
                #+ecl (multiple-value-bind (status code)
                          (ext:external-process-wait process t)
                        (if (eq status :signaled)
                            (values nil code)
                            code))
                #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
                                     #-lispworks7+ #'sys:pid-exit-status
                                     process :wait t)
                #+mkcl (let ((code (mkcl:join-process process)))
                         (if (stringp code)
                             (values nil (%mkcl-signal-to-number code))
                             code))
                #+sbcl (let ((status (sb-ext:process-status process))
                             (code (sb-ext:process-exit-code process)))
                         (if (eq status :signaled)
                             (values nil code)
                             code)))
            (if signal-code
                (let ((%exit-code (%signal-to-exit-code signal-code)))
                  (setf (slot-value process-info 'exit-code) %exit-code
                        (slot-value process-info 'signal-code) signal-code)
                  (values %exit-code signal-code))
                (progn (setf (slot-value process-info 'exit-code) exit-code)
                       exit-code)))))))
800 801 802 803 804 805 806 807

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

Elias Pipping's avatar
Elias Pipping committed
808 809 810 811 812 813 814 815 816 817 818 819
  (defun close-streams (process-info)
    "Close any stream that the process might own. Needs to be run
whenever streams were requested by passing :stream to :input, :output,
or :error-output."
    (dolist (stream
              (cons (slot-value process-info 'error-output-stream)
                    (if-let (bidir-stream (slot-value process-info 'bidir-stream))
                      (list bidir-stream)
                      (list (slot-value process-info 'input-stream)
                            (slot-value process-info 'output-stream)))))
      (when stream (close stream))))

820 821
  ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
  ;; do what you expect it to. Sending SIGSTOP to a process spawned
822
  ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
823 824
  ;; to run the command (via `sh -c command`) but not the actual
  ;; command.
Robert Goldman's avatar
Robert Goldman committed
825
  #+os-unix
826 827 828 829 830 831 832
  (defun %posix-send-signal (process-info signal)
    #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
    #+clozure (ccl:signal-external-process (slot-value process-info 'process)
                                           signal :error-if-exited nil)
    #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
    #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
    #-(or allegro clozure cmucl sbcl scl)
Elias Pipping's avatar
Elias Pipping committed
833
    (if-let (pid (process-info-pid process-info))
834 835
      (run-program (format nil "kill -~a ~a" signal pid)
                   :ignore-error-status t)))
836

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

844 845 846 847 848 849 850 851 852 853 854 855 856 857 858
  (defun terminate-process (process-info &key urgent)
    "Cause the process to exit. To that end, the process may or may
not be sent a signal, which it will find harder (or even impossible)
to ignore if URGENT is T. On some platforms, it may also be subject to
race conditions."
    (declare (ignorable urgent))
    #+abcl (sys:process-kill (slot-value process-info 'process))
    #+ecl (symbol-call :ext :terminate-process
                       (slot-value process-info 'process) urgent)
    #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
    #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
                                     :force urgent)
    #-(or abcl ecl lispworks7+ mkcl)
    (os-cond
     ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
Elias Pipping's avatar
Elias Pipping committed
859
     ((os-windows-p) (if-let (pid (process-info-pid process-info))
860 861 862
                       (run-program (format nil "taskkill ~a /pid ~a"
                                            (if urgent "/f" "") pid)
                                    :ignore-error-status t)))
863 864
     (t (not-implemented-error 'terminate-process))))

865 866 867 868 869 870 871 872
  (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
                                &key element-type external-format &allow-other-keys)
    ;; handle redirection for run-program and system
    ;; SPEC is the specification for the subprocess's input or output or error-output
    ;; TVAL is the value used if the spec is T
    ;; GF is the generic function to call to handle arbitrary values of SPEC
    ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
    ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
873
    ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
874 875 876 877 878 879 880
    ;; FUN is a function of the new reduced spec and an activity function to call with a stream
    ;; when the subprocess is active and communicating through that stream.
    ;; ACTIVEP is a boolean true if we will get to run code while the process is running
    ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
    ;; RETURNER is a function called with the value of the activity.
    ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
    (declare (ignorable stream-easy-p))
881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896
    (let* ((actual-spec (if (eq spec t) tval spec))
           (activity-spec (if (eq actual-spec :output)
                              (ecase direction
                                ((:input :output)
                                 (error "~S not allowed as a ~S ~S spec"
                                        :output 'run-program direction))
                                ((:error-output)
                                 nil))
                              actual-spec)))
      (labels ((activity (stream)
                 (call-function returner (call-stream-processor gf activity-spec stream)))
               (easy-case ()
                 (funcall fun actual-spec nil))
               (hard-case ()
                 (if activep
                     (funcall fun :stream #'activity)
897
                     (with-temporary-file (:pathname tmp)
898 899
                       (ecase direction
                         (:input
900 901 902 903
                          (with-output-file (s tmp :if-exists :overwrite
                                               :external-format external-format
                                               :element-type element-type)
                            (activity s))
904 905
                          (funcall fun tmp nil))
                         ((:output :error-output)
906 907 908 909 910
                          (multiple-value-prog1 (funcall fun tmp nil)
                            (with-input-file (s tmp
                                               :external-format external-format
                                               :element-type element-type)
                              (activity s)))))))))
911 912 913
        (typecase activity-spec
          ((or null string pathname (eql :interactive))
           (easy-case))
914
          #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
915 916 917 918
          (stream
           (if stream-easy-p (easy-case) (hard-case)))
          (t
           (hard-case))))))
919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950

  (defmacro place-setter (place)
    (when place
      (let ((value (gensym)))
        `#'(lambda (,value) (setf ,place ,value)))))

  (defmacro with-program-input (((reduced-input-var
                                  &optional (input-activity-var (gensym) iavp))
                                 input-form &key setf stream-easy-p active keys) &body body)
    `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
            #'(lambda (,reduced-input-var ,input-activity-var)
                ,@(unless iavp `((declare (ignore ,input-activity-var))))
                ,@body)
            :input ,input-form ,active (place-setter ,setf) ,keys))

  (defmacro with-program-output (((reduced-output-var
                                  &optional (output-activity-var (gensym) oavp))
                                  output-form &key setf stream-easy-p active keys) &body body)
    `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
            #'(lambda (,reduced-output-var ,output-activity-var)
                ,@(unless oavp `((declare (ignore ,output-activity-var))))
                ,@body)
            :output ,output-form ,active (place-setter ,setf) ,keys))

  (defmacro with-program-error-output (((reduced-error-output-var
                                         &optional (error-output-activity-var (gensym) eoavp))
                                        error-output-form &key setf stream-easy-p active keys)
                                       &body body)
    `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
            #'(lambda (,reduced-error-output-var ,error-output-activity-var)
                ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
                ,@body)
951
            :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
952

953
  (defun %use-launch-program (command &rest keys
954
                           &key input output error-output ignore-error-status &allow-other-keys)
955
    ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
Elias Pipping's avatar
Elias Pipping committed
956
    #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
957 958
    (progn
      command keys input output error-output ignore-error-status ;; ignore
959
      (not-implemented-error '%use-launch-program))
960 961 962
    (assert (not (member :stream (list input output error-output))))
    (let* ((active-input-p (%active-io-specifier-p input))
           (active-output-p (%active-io-specifier-p output))
963
           (active-error-output-p (%active-io-specifier-p error-output))
964 965 966 967 968 969 970
           (activity
             (cond
               (active-output-p :output)
               (active-input-p :input)
               (active-error-output-p :error-output)
               (t nil)))
           (wait (not activity))
971
           output-result error-output-result exit-code process-info)
972 973 974 975
      (with-program-output ((reduced-output output-activity)
                            output :keys keys :setf output-result
                            :stream-easy-p t :active (eq activity :output))
        (with-program-error-output ((reduced-error-output error-output-activity)
976
                                    error-output :keys keys :setf error-output-result
977 978 979 980
                                    :stream-easy-p t :active (eq activity :error-output))
          (with-program-input ((reduced-input input-activity)
                               input :keys keys
                               :stream-easy-p t :active (eq activity :input))
981
            (setf process-info
982
                  (apply 'launch-program command
Elias Pipping's avatar
Elias Pipping committed
983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001
                         :wait wait :input reduced-input :output reduced-output
                         :error-output (if (eq error-output :output) :output reduced-error-output)
                         keys))
            (labels ((get-stream (stream-name &optional fallbackp)
                       (or (slot-value process-info stream-name)
                           (when fallbackp
                             (slot-value process-info 'bidir-stream))))
                     (run-activity (activity stream-name &optional fallbackp)
                       (if-let (stream (get-stream stream-name fallbackp))
                         (funcall activity stream)
                         (error 'subprocess-error
                                :code `(:missing ,stream-name)
                                :command command :process process-info))))
              (unwind-protect
                   (ecase activity
                     ((nil))
                     (:input (run-activity input-activity 'input-stream t))
                     (:output (run-activity output-activity 'output-stream t))
                     (:error-output (run-activity error-output-activity 'error-output-stream)))
Elias Pipping's avatar
Elias Pipping committed
1002
                (close-streams process-info)
1003
                (setf exit-code (wait-process process-info)))))))
1004 1005 1006
      (%check-result exit-code
                     :command command :process process-info
                     :ignore-error-status ignore-error-status)
1007 1008
      (values output-result error-output-result exit-code)))

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

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

1053 1054 1055
  (defun %system (command &rest keys
                  &key input output error-output directory &allow-other-keys)
    "A portable abstraction of a low-level call to libc's system()."
1056
    (declare (ignorable input output error-output directory keys))
1057
    #+(or allegro clozure cmucl (and lispworks os-unix) sbcl scl)
1058
    (wait-process
1059
     (apply 'launch-program (%normalize-system-command command) :wait t keys))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1060
    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
1061 1062 1063
    (let ((%command (%redirected-system-command command input output error-output directory)))
      #+(and lispworks os-windows)
      (system:call-system %command :current-directory directory :wait t)
1064
      #+clisp
1065
      (wait-process
1066
       (apply 'launch-program %command :wait t
1067 1068
              :input :interactive :output :interactive :error-output :interactive keys))
      #-(or clisp (and lispworks os-windows))
1069
      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
Elias Pipping's avatar
Elias Pipping committed
1070
        #+abcl (ext:run-shell-command %command) ;; FIXME: deprecated
1071
        #+cormanlisp (win32:system %command)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1072
        #+(or clasp ecl) (let ((*standard-input* *stdin*)
1073 1074 1075
                               (*standard-output* *stdout*)
                               (*error-output* *stderr*))
                           (ext:system %command))
1076
        #+gcl (system:system %command)
Elias Pipping's avatar
Elias Pipping committed
1077
        #+genera (not-implemented-error '%system)
1078
        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
1079
        #+mkcl (mkcl:system %command)
1080
        #+xcl (system:%run-shell-command %command))))
1081 1082 1083

  (defun %use-system (command &rest keys
                      &key input output error-output ignore-error-status &allow-other-keys)
1084
    ;; helper for RUN-PROGRAM when using %system
1085 1086 1087 1088 1089 1090
    (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)
1091 1092 1093 1094 1095 1096
            (setf exit-code (apply '%system command
                                   :input reduced-input :output reduced-output
                                   :error-output reduced-error-output keys)))))
      (%check-result exit-code
                     :command command
                     :ignore-error-status ignore-error-status)
1097 1098 1099
      (values output-result error-output-result exit-code)))

  (defun run-program (command &rest keys
1100
                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
1101
                         (input nil inputp) (if-input-does-not-exist :error)
1102 1103
                         output (if-output-exists :supersede)
                         (error-output nil error-output-p) (if-error-output-exists :supersede)
1104 1105 1106
                         (element-type #-clozure *default-stream-element-type* #+clozure 'character)
                         (external-format *utf-8-external-format*)
                      &allow-other-keys)
1107
    "Run program specified by COMMAND,
1108
either a list of strings specifying a program and list of arguments,
1109 1110 1111
or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
_synchronously_ process its output as specified and return the processing results
when the program and its output processing are complete.
1112

1113
Always call a shell (rather than directly execute the command when possible)
1114 1115
if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
specified to be NIL.
1116

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

1120 1121
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.
1122 1123 1124 1125
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.
1126
Otherwise, OUTPUT should be a value that is a suitable first argument to
1127
SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
1128 1129
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,
1130 1131 1132 1133
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.