launch-program.lisp 32.9 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
;;;; -------------------------------------------------------------------------
;;;; launch-program - semi-portably spawn asynchronous subprocesses

(uiop/package:define-package :uiop/launch-program
  (:use :uiop/common-lisp :uiop/package :uiop/utility
   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
  (:export
   ;;; Escaping the command invocation madness
   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
   #:escape-windows-token #:escape-windows-command
   #:escape-shell-token #:escape-shell-command
   #:escape-token #:escape-command

   ;;; launch-program
   #:launch-program
   #:close-streams #:process-alive-p #:terminate-process #:wait-process
   #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid))
(in-package :uiop/launch-program)

;;;; ----- Escaping strings for the shell -----
(with-upgradability ()
  (defun requires-escaping-p (token &key good-chars bad-chars)
    "Does this token require escaping, given the specification of
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."
    (some
     (cond
       ((and good-chars bad-chars)
29 30
        (parameter-error "~S: only one of good-chars and bad-chars can be provided"
                         'requires-escaping-p))
31 32 33 34 35 36 37 38
       ((typep good-chars 'function)
        (complement good-chars))
       ((typep bad-chars 'function)
        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)))
39
       (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p)))
40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
     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
REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
using STREAM as output (or returning result as a string if NIL)"
    (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)))

  (defun escape-windows-token-within-double-quotes (x &optional s)
    "Escape a string token X within double-quotes
for use within a MS Windows command-line, outputing to S."
    (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 easy-windows-character-p (x)
    "Is X an \"easy\" character that does not require quoting by the shell?"
    (or (alphanumericp x) (find x "+-_.,@:/=")))

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

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

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

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

  (defun escape-shell-token (token &optional s)
    "Escape a token for the current operating system shell"
    (os-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
spaced, escaped tokens, using ESCAPER to escape."
    (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
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
    (escape-command command s 'escape-windows-token))

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

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


(with-upgradability ()
  ;;; Internal helpers for run-program
  (defun %normalize-io-specifier (specifier &optional role)
    "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
argument to pass to the internal RUN-PROGRAM"
    (declare (ignorable role))
    (typecase specifier
      (null (or #+(or allegro lispworks) (null-device-pathname)))
      (string (parse-native-namestring specifier))
      (pathname specifier)
      (stream specifier)
      ((eql :stream) :stream)
      ((eql :interactive)
       #+(or allegro lispworks) nil
       #+clisp :terminal
       #+(or abcl clozure cmucl ecl mkcl sbcl scl) t
       #-(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp)
       (not-implemented-error :interactive-output
                              "On this lisp implementation, cannot interpret ~a value of ~a"
                              specifier role))
      ((eql :output)
       (cond ((eq role :error-output)
              #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
              :output
              #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl)
              (not-implemented-error :error-output-redirect
                                     "Can't send ~a to ~a on this lisp implementation."
                                     role specifier))
             (t (parameter-error "~S IO specifier invalid for ~S" specifier role))))
      (otherwise
       (parameter-error "Incorrect I/O specifier ~S for ~S"
                        specifier role))))

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

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

Elias Pipping's avatar
Elias Pipping committed
179 180 181 182 183
  (defun %code-to-status (exit-code signal-code)
    (cond ((null exit-code) :running)
          ((null signal-code) (values :exited exit-code))
          (t (values :signaled signal-code))))

184 185 186 187 188 189
  #+mkcl
  (defun %mkcl-signal-to-number (signal)
    (require :mk-unix)
    (symbol-value (find-symbol signal :mk-unix)))

  (defclass process-info ()
190 191 192 193 194 195 196 197 198 199 200 201 202 203
    (;; The process field is highly platform-, implementation-, and
     ;; even version-dependent.
     ;; Prior to LispWorks 7, the only information that
     ;; `sys:run-shell-command` with `:wait nil` was certain to return
     ;; is a PID (e.g. when all streams are nil), hence we stored it
     ;; and used `sys:pid-exit-status` to obtain an exit status
     ;; later. That is still what we do.
     ;; From LispWorks 7 on, if `sys:run-shell-command` does not
     ;; return a proper stream, we are instead given a dummy stream.
     ;; We can thus always store a stream and use
     ;; `sys:pipe-exit-status` to obtain an exit status later.
     ;; The advantage of dealing with streams instead of PID is the
     ;; availability of functions like `sys:pipe-kill-process`.
     (process :initform nil)
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
     (input-stream :initform nil)
     (output-stream :initform nil)
     (bidir-stream :initform nil)
     (error-output-stream :initform nil)
     ;; 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)))

;;;---------------------------------------------------------------------------
;;; The following two helper functions take care of handling the IF-EXISTS and
;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
;;; function to treat input and output files unconditionally for reading and
;;; writing.
;;;---------------------------------------------------------------------------

  (defun %handle-if-exists (file if-exists)
    (when (or (stringp file) (pathnamep file))
      (ecase if-exists
        ((:append :supersede :error)
         (with-open-file (dummy file :direction :output :if-exists if-exists)
           (declare (ignorable dummy)))))))

  (defun %handle-if-does-not-exist (file if-does-not-exist)
    (when (or (stringp file) (pathnamep file))
      (ecase if-does-not-exist
        ((:create :error)
         (with-open-file (dummy file :direction :probe
                                :if-does-not-exist if-does-not-exist)
           (declare (ignorable dummy)))))))

  (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)))

  (defun process-info-pid (process-info)
    (let ((process (slot-value process-info 'process)))
      (declare (ignorable process))
      #+abcl (symbol-call :sys :process-pid process)
      #+allegro process
      #+clozure (ccl:external-process-id process)
      #+ecl (ext:external-process-pid process)
      #+(or cmucl scl) (ext:process-pid process)
      #+lispworks7+ (sys:pipe-pid process)
      #+(and lispworks (not lispworks7+)) process
      #+mkcl (mkcl:process-id process)
      #+sbcl (sb-ext:process-pid process)
      #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl)
      (not-implemented-error 'process-info-pid)))

  (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
Elias Pipping's avatar
Elias Pipping committed
274
            #+allegro (multiple-value-bind (exit-code pid signal-code)
275 276
                          (sys:reap-os-subprocess :pid process :wait nil)
                        (assert pid)
Elias Pipping's avatar
Elias Pipping committed
277
                        (%code-to-status exit-code signal-code))
278 279
            #+clozure (ccl:external-process-status process)
            #+(or cmucl scl) (let ((status (ext:process-status process)))
Elias Pipping's avatar
Elias Pipping committed
280 281 282 283 284 285
                               (if (member status '(:exited :signaled))
                                   ;; Calling ext:process-exit-code on
                                   ;; processes that are still alive
                                   ;; yields an undefined result
                                   (values status (ext:process-exit-code process))
                                   status))
286 287 288
            #+ecl (ext:external-process-status process)
            #+lispworks
            ;; a signal is only returned on LispWorks 7+
Elias Pipping's avatar
Elias Pipping committed
289
            (multiple-value-bind (exit-code signal-code)
290 291 292 293
                (symbol-call :sys
                             #+lispworks7+ :pipe-exit-status
                             #-lispworks7+ :pid-exit-status
                             process :wait nil)
Elias Pipping's avatar
Elias Pipping committed
294
              (%code-to-status exit-code signal-code))
295 296 297 298 299 300 301 302 303
            #+mkcl (let ((status (mk-ext:process-status process)))
                     (if (eq status :exited)
                         ;; Only call mk-ext:process-exit-code when
                         ;; necessary since it leads to another waitpid()
                         (let ((code (mk-ext:process-exit-code process)))
                           (if (stringp code)
                               (values :signaled (%mkcl-signal-to-number code))
                               (values :exited code)))
                         status))
304
            #+sbcl (let ((status (sb-ext:process-status process)))
305 306 307 308 309 310
                     (if (eq status :running)
                         :running
                         ;; sb-ext:process-exit-code can also be
                         ;; called for stopped processes to determine
                         ;; the signal that stopped them
                         (values status (sb-ext:process-exit-code process)))))
311 312 313 314 315
        (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))))
316 317 318
        (if code
            (values status code)
            status))))
319 320 321 322 323 324 325

  (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))
326 327
      #-(or abcl cmucl sbcl scl) (find (%process-status process-info)
                                       '(:running :stopped :continued :resumed))))
328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373

  (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
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.
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."
    (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))
374 375 376 377
                #+lispworks (symbol-call :sys
                                         #+lispworks7+ :pipe-exit-status
                                         #-lispworks7+ :pid-exit-status
                                         process :wait t)
378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408
                #+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)))))))

  ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
  ;; do what you expect it to. Sending SIGSTOP to a process spawned
  ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
  ;; to run the command (via `sh -c command`) but not the actual
  ;; command.
  #+os-unix
  (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)
    (if-let (pid (process-info-pid process-info))
409 410
      (symbol-call :uiop :run-program
                   (format nil "kill -~a ~a" signal pid) :ignore-error-status t)))
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431

  ;;; 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))

  (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))
    ;; On ECL, this will only work on versions later than 2016-09-06,
    ;; but we still want to compile on earlier versions, so we use symbol-call
    #+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)
432
    #-(or abcl ecl lispworks7+ mkcl)
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 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533
    (os-cond
     ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
     ((os-windows-p) (if-let (pid (process-info-pid process-info))
                       (symbol-call :uiop :run-program
                                    (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid)
                                    :ignore-error-status t)))
     (t (not-implemented-error 'terminate-process))))

  (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))))

  (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
                           #+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 (the
default) 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.

IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
default). The meaning of these values and their effect on the case
where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
to OPEN with :DIRECTION :OUTPUT.

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.

IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
affects ERROR-OUTPUT rather than 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.

IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
or a pathname, can take the values :CREATE and :ERROR (the
default). The meaning of these values is analogous to the
IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :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."
    #-(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
    (progn command keys input output error-output directory element-type external-format
           if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore
           (not-implemented-error 'launch-program))
    #+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"
                       'launch-program))
    #+(or abcl clisp lispworks)
    (when (some #'streamp (list input output error-output))
      (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
                       'launch-program))
    #+clisp
    (unless (eq error-output :interactive)
      (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
                       'launch-program :error-output :interactive))
    #+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"
                       'launch-program))
    #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
534 535 536 537 538
    (nest
     (progn ;; see comments for these functions
       (%handle-if-does-not-exist input if-input-does-not-exist)
       (%handle-if-exists output if-output-exists)
       (%handle-if-exists error-output if-error-output-exists))
539 540 541
     #+ecl (let ((*standard-input* *stdin*)
                 (*standard-output* *stdout*)
                 (*error-output* *stderr*)))
542
     (let ((process-info (make-instance 'process-info))
543 544 545
           (input (%normalize-io-specifier input :input))
           (output (%normalize-io-specifier output :output))
           (error-output (%normalize-io-specifier error-output :error-output))
546
           #+(and allegro os-windows) (interactive (%interactivep input output error-output))
547 548 549 550 551 552
           (command
            (etypecase command
              #+os-unix (string `("/bin/sh" "-c" ,command))
              #+os-unix (list command)
              #+os-windows
              (string
553 554 555
               ;; 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.
556
               #-(or allegro clisp clozure ecl)
557
               (nest
558 559
                #+(or ecl sbcl) (unless (find-symbol* :escape-arguments #+ecl :ext #+sbcl :sb-impl nil))
                (parameter-error "~S doesn't support string commands on Windows on this Lisp"
560
                                 'launch-program command))
561 562
               ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
               ;; when the command contains spaces or special characters:
563 564 565 566
               ;; IIUC, the system will use space as a separator,
               ;; but the C++ argv-decoding libraries won't, and
               ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
               ;; yet neither allegro nor clisp provide access to that argument.
567 568 569 570
               #+(or allegro clisp) (strcat "cmd /c " 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
571
               ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304
572
               ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
573
               #+(or clozure ecl sbcl) (cons "cmd" (strcat "/c " command)))
574 575 576 577
              #+os-windows
              (list
               #+allegro (escape-windows-command command)
               #-allegro command)))))
578 579 580
     #+(or abcl (and allegro os-unix) clozure cmucl ecl mkcl sbcl)
     (let ((program (car command))
           #-allegro (arguments (cdr command))))
581
     #+(and (or ecl sbcl) os-windows)
582 583 584 585
     (multiple-value-bind (arguments escape-arguments)
         (if (listp arguments)
             (values arguments t)
             (values (list arguments) nil)))
586
     #-(or allegro mkcl sbcl) (with-current-directory (directory))
587 588 589 590 591 592
     (multiple-value-bind
       #+(or abcl clozure cmucl sbcl scl) (process)
       #+allegro (in-or-io out-or-err err-or-pid pid-or-nil)
       #+ecl (stream code process)
       #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil)
       #+mkcl (stream process code)
593 594 595 596 597 598 599 600 601 602 603
       #.`(apply
           #+abcl 'sys:run-program
           #+allegro ,@'('excl:run-shell-command
                         #+os-unix (coerce (cons program command) 'vector)
                         #+os-windows command)
           #+clozure 'ccl:run-program
           #+(or cmucl ecl scl) 'ext:run-program
           #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed
           #+mkcl 'mk-ext:run-program
           #+sbcl 'sb-ext:run-program
           #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments)
604
           #+(and (or ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments)
605 606 607 608 609 610 611 612 613 614 615 616
           :input input :if-input-does-not-exist :error
           :output output :if-output-exists :append
           ,(or #+(or allegro lispworks) :error-output :error) error-output
           ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append
           :wait nil :element-type element-type :external-format external-format
           :allow-other-keys t
           #+allegro ,@`(:directory directory
                         #+os-windows ,@'(:show-window (if interactive nil :hide)))
           #+lispworks ,@'(:save-exit-status t)
           #+mkcl ,@'(:directory (native-namestring directory))
           #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
           #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys)))))
617
     (labels ((prop (key value) (setf (slot-value process-info key) value)))
618 619 620 621 622 623 624 625 626 627 628 629 630 631
       #+allegro
       (cond
         (separate-streams
          (prop 'process pid-or-nil)
          (when (eq input :stream) (prop 'input-stream in-or-io))
          (when (eq output :stream) (prop 'output-stream out-or-err))
          (when (eq error-output :stream) (prop 'error-stream err-or-pid)))
         (t
          (prop 'process err-or-pid)
          (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
            (0)
            (1 (prop 'input-stream in-or-io))
            (2 (prop 'output-stream in-or-io))
            (3 (prop 'bidir-stream in-or-io)))
632
          (when (eq error-output :stream)
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 662 663 664 665 666 667
            (prop 'error-stream out-or-err))))
       #+(or abcl clozure cmucl sbcl scl)
       (progn
         (prop 'process process)
         (when (eq input :stream)
           (nest
            (prop 'input-stream)
            #+abcl (symbol-call :sys :process-input)
            #+clozure (ccl:external-process-input-stream)
            #+(or cmucl scl) (ext:process-input)
            #+sbcl (sb-ext:process-input)
            process))
         (when (eq output :stream)
           (nest
            (prop 'output-stream)
            #+abcl (symbol-call :sys :process-output)
            #+clozure (ccl:external-process-output-stream)
            #+(or cmucl scl) (ext:process-output)
            #+sbcl (sb-ext:process-output)
            process))
         (when (eq error-output :stream)
           (nest
            (prop 'error-output-stream)
            #+abcl (symbol-call :sys :process-error)
            #+clozure (ccl:external-process-error-stream)
            #+(or cmucl scl) (ext:process-error)
            #+sbcl (sb-ext:process-error)
            process)))
       #+(or ecl mkcl)
       (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
         code ;; ignore
         (unless (zerop mode)
           (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))
         (prop 'process process))
       #+lispworks
668
       ;; See also the comments on the process-info class
669 670 671 672 673
       (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
         (cond
           ((or (plusp mode) (eq error-output :stream))
            (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil)
            (when (plusp mode)
674 675
              (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream))
                    io-or-pid))
676 677
            (when (eq error-output :stream)
              (prop 'error-stream err-or-nil)))
678 679
           ;; Prior to Lispworks 7, this returned (pid); now it
           ;; returns (io err pid) of which we keep io.
680
           (t (prop 'process io-or-pid)))))
681
     process-info)))
682