src/code/run-program.lisp

   1 ;;;; RUN-PROGRAM and friends, a facility for running Unix programs
   2 ;;;; from inside SBCL
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)
  14 \f
  15 ;;;; hacking the Unix environment
  16 ;;;;
  17 ;;;; In the original CMU CL code that LOAD-FOREIGN is derived from, the
  18 ;;;; Unix environment (as in "man environ") was represented as an
  19 ;;;; alist from keywords to strings, so that e.g. the Unix environment
  20 ;;;;   "SHELL=/bin/bash" "HOME=/root" "PAGER=less"
  21 ;;;; was represented as
  22 ;;;;   ((:SHELL . "/bin/bash") (:HOME . "/root") (:PAGER "less"))
  23 ;;;; This had a few problems in principle: the mapping into
  24 ;;;; keyword symbols smashed the case of environment
  25 ;;;; variables, and the whole mapping depended on the presence of
  26 ;;;; #\= characters in the environment strings. In practice these
  27 ;;;; problems weren't hugely important, since conventionally environment
  28 ;;;; variables are uppercase strings followed by #\= followed by
  29 ;;;; arbitrary data. However, since it's so manifestly not The Right
  30 ;;;; Thing to make code which breaks unnecessarily on input which
  31 ;;;; doesn't follow what is, after all, only a tradition, we've switched
  32 ;;;; formats in SBCL, so that the fundamental environment list
  33 ;;;; is just a list of strings, with a one-to-one-correspondence
  34 ;;;; to the C-level representation. I.e., in the example above,
  35 ;;;; the SBCL representation is
  36 ;;;;   '("SHELL=/bin/bash" "HOME=/root" "PAGER=less")
  37 ;;;; CMU CL's implementation is currently supported to help with porting.
  38 ;;;;
  39 ;;;; It's not obvious that this code belongs here (instead of e.g. in
  40 ;;;; unix.lisp), since it has only a weak logical connection with
  41 ;;;; RUN-PROGRAM. However, physically it's convenient to put it here.
  42 ;;;; It's not needed at cold init, so we *can* put it in this
  43 ;;;; warm-loaded file. And by putting it in this warm-loaded file, we
  44 ;;;; make it easy for it to get to the C-level 'environ' variable.
  45 ;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not
  46 ;;;; visible at GENESIS time.
  47
  48 #-win32
  49 (progn
  50   (define-alien-routine wrapped-environ (* c-string))
  51   (defun posix-environ ()
  52     "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs."
  53     (c-strings->string-list (wrapped-environ))))
  54
  55 #+win32
  56 (progn
  57   (defun decode-windows-environment (environment)
  58     (loop until (zerop (sap-ref-8 environment 0))
  59           collect
  60           (let ((string (sb-alien::c-string-to-string environment
  61                                                       (sb-alien::default-c-string-external-format)
  62                                                       'character)))
  63             (loop for value = (sap-ref-8 environment 0)
  64                   do (setf environment (sap+ environment 1))
  65                   until (zerop value))
  66             string)))
  67
  68   (defun encode-windows-environment (list)
  69     (let* ((external-format (sb-alien::default-c-string-external-format))
  70            octets
  71            (length 1)) ;; 1 for \0 at the very end
  72       (setf octets
  73             (loop for x in list
  74                   for octet =
  75                   (string-to-octets x :external-format external-format
  76                                       :null-terminate t)
  77                   collect octet
  78                   do
  79                   (incf length (length octet))))
  80       (let ((mem (allocate-system-memory length))
  81             (index 0))
  82
  83         (loop for string in octets
  84               for length = (length string)
  85               do
  86               (copy-ub8-to-system-area string 0 mem index length)
  87               (incf index length))
  88         (setf (sap-ref-8 mem index) 0)
  89         (values mem mem length))))
  90
  91   (defun posix-environ ()
  92     (decode-windows-environment
  93      (alien-funcall (extern-alien "GetEnvironmentStrings"
  94                                   (function system-area-pointer))))))
  95
  96 ;;; Convert from a CMU CL representation of a Unix environment to a
  97 ;;; SBCL representation.
  98 (defun unix-environment-sbcl-from-cmucl (cmucl)
  99   (mapcar
 100    (lambda (cons)
 101      (destructuring-bind (key . val) cons
 102        (declare (type keyword key) (string val))
 103        (concatenate 'simple-string (symbol-name key) "=" val)))
 104    cmucl))
 105 \f
 106 #-win32
 107 (define-alien-routine ("waitpid" c-waitpid) int
 108   (pid int)
 109   (status int :out)
 110   (options int))
 111
 112 #-win32
 113 (defun waitpid (pid)
 114   "Return any available status information on child process with PID."
 115   (multiple-value-bind (pid status)
 116       (c-waitpid pid
 117                  (logior sb-unix:wnohang sb-unix:wuntraced sb-unix:wcontinued))
 118     (cond ((or (minusp pid)
 119                (zerop pid))
 120            (values nil nil nil))
 121           ((wifcontinued status)
 122            (values :running
 123                    nil
 124                    nil))
 125           ((wifstopped status)
 126            (values :stopped
 127                    (ldb (byte 8 8) status)
 128                    nil))
 129           ((zerop (ldb (byte 7 0) status))
 130            (values :exited
 131                    (ldb (byte 8 8) status)
 132                    nil))
 133           (t
 134            (let ((signal (ldb (byte 7 0) status)))
 135              (values (if (position signal
 136                                    #.(vector
 137                                       sb-unix:sigstop
 138                                       sb-unix:sigtstp
 139                                       sb-unix:sigttin
 140                                       sb-unix:sigttou))
 141                          :stopped
 142                          :signaled)
 143                      signal
 144                      (not (zerop (ldb (byte 1 7) status)))))))))
 145
 146 #-win32
 147 (define-alien-routine wifcontinued boolean
 148   (status int))
 149
 150 #-win32
 151 (define-alien-routine wifstopped boolean
 152   (status int))
 153 \f
 154 ;;;; process control stuff
 155 (define-load-time-global *active-processes* nil
 156   "List of process structures for all active processes.")
 157
 158 (define-load-time-global *active-processes-lock*
 159   (sb-thread:make-mutex :name "Lock for active processes."))
 160
 161 ;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a
 162 ;;; mutex is needed. More importantly the sigchld signal handler also
 163 ;;; accesses it, that's why we need without-interrupts.
 164 (defmacro with-active-processes-lock (() &body body)
 165   `(sb-thread::with-system-mutex (*active-processes-lock*)
 166      ,@body))
 167
 168 (deftype process-status ()
 169   '(member :running :stopped :exited :signaled))
 170
 171 (defstruct (process (:copier nil))
 172   (pid     nil :type word :read-only t) ; PID of child process
 173   (%status nil :type process-status)
 174   %exit-code                            ; either exit code or signal
 175   core-dumped                           ; T if a core image was dumped
 176   #-win32 pty                           ; stream to child's pty, or NIL
 177   input                                 ; stream to child's input, or NIL
 178   output                                ; stream from child's output, or NIL
 179   error                                 ; stream from child's error output, or NIL
 180   status-hook                           ; closure to call when PROC changes status
 181   plist                                 ; a place for clients to stash things
 182   (cookie nil :type cons :read-only t)  ; list of the number of pipes from the subproc
 183   #+win32 copiers ; list of sb-win32::io-copier
 184   #+win32 (handle nil :type (or null (signed-byte 32))))
 185
 186 (defmethod print-object ((process process) stream)
 187   (print-unreadable-object (process stream :type t)
 188     (let ((status (process-status process)))
 189       (if (eq :exited status)
 190           (format stream "~S ~S" status (process-%exit-code process))
 191           (format stream "~S ~S" (process-pid process) status)))
 192     process))
 193
 194 #+win32
 195 (define-alien-routine ("GetExitCodeProcess" get-exit-code-process)
 196     int
 197   (handle unsigned) (exit-code unsigned :out))
 198
 199 (defun process-exit-code (process)
 200   "Return the exit code of PROCESS."
 201   (or (process-%exit-code process)
 202       (progn (get-processes-status-changes)
 203              (process-%exit-code process))))
 204
 205 (defun process-status (process)
 206   "Return the current status of PROCESS.  The result is one of :RUNNING,
 207    :STOPPED, :EXITED, or :SIGNALED."
 208   (get-processes-status-changes)
 209   (process-%status process))
 210
 211 (setf (documentation 'process-exit-code 'function)
 212       "The exit code or the signal of a stopped process."
 213       (documentation 'process-core-dumped 'function)
 214       "T if a core image was dumped by the process."
 215       (documentation 'process-pty 'function)
 216       "The pty stream of the process or NIL."
 217       (documentation 'process-input 'function)
 218       "The input stream of the process or NIL."
 219       (documentation 'process-output 'function)
 220       "The output stream of the process or NIL."
 221       (documentation 'process-error 'function)
 222       "The error stream of the process or NIL."
 223       (documentation 'process-status-hook 'function) "A function that is called when PROCESS changes its status.
 224 The function is called with PROCESS as its only argument."
 225       (documentation 'process-plist 'function)
 226       "A place for clients to stash things."
 227       (documentation 'process-p 'function)
 228       "T if OBJECT is a PROCESS, NIL otherwise."
 229       (documentation 'process-pid 'function) "The pid of the child process.")
 230
 231 (defun process-wait (process &optional check-for-stopped)
 232   "Wait for PROCESS to quit running for some reason. When
 233 CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns
 234 PROCESS."
 235   (declare (ignorable check-for-stopped))
 236   #+win32
 237   (sb-win32::win32-process-wait process)
 238   #-win32
 239   (loop
 240       (case (process-status process)
 241         (:running)
 242         (:stopped
 243          (when check-for-stopped
 244            (return)))
 245         (t
 246          (when (zerop (car (process-cookie process)))
 247            (return))))
 248       (serve-all-events 1))
 249   process)
 250
 251 #-win32
 252 ;;; Find the current foreground process group id.
 253 (defun find-current-foreground-process (proc)
 254   (with-alien ((result int))
 255     (multiple-value-bind
 256           (wonp error)
 257         (sb-unix:unix-ioctl (fd-stream-fd (process-pty proc))
 258                             sb-unix:TIOCGPGRP
 259                             (alien-sap (addr result)))
 260       (unless wonp
 261         (error "TIOCPGRP ioctl failed: ~S" (strerror error)))
 262       result))
 263   (process-pid proc))
 264
 265 #-win32
 266 (defun process-kill (process signal &optional (whom :pid))
 267   "Hand SIGNAL to PROCESS. If WHOM is :PID, use the kill Unix system call. If
 268    WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is
 269    :PTY-PROCESS-GROUP deliver the signal to whichever process group is
 270    currently in the foreground."
 271   (let ((pid (ecase whom
 272                ((:pid :process-group)
 273                 (process-pid process))
 274                (:pty-process-group
 275                 (find-current-foreground-process process)))))
 276     (let ((result (if (eq whom :process-group)
 277                       (sb-unix:unix-killpg pid signal)
 278                       (sb-unix:unix-kill pid signal))))
 279       (or (zerop result)
 280           (values nil (sb-unix::get-errno))))))
 281
 282 #+win32
 283 (defun process-kill (process signal &optional (whom :pid))
 284   (declare (ignore signal whom))
 285   (get-processes-status-changes)
 286   (let ((handle (process-handle process)))
 287     (when handle
 288       (prog1 (sb-win32::terminate-process handle 1)
 289         (get-processes-status-changes)))))
 290
 291 (defun process-alive-p (process)
 292   "Return T if PROCESS is still alive, NIL otherwise."
 293   (let ((status (process-status process)))
 294     (if (or (eq status :running)
 295             (eq status :stopped))
 296         t
 297         nil)))
 298
 299 (defun process-close (process)
 300   "Close all streams connected to PROCESS and stop maintaining the
 301 status slot."
 302   (macrolet ((frob (stream abort)
 303                `(when ,stream (close ,stream :abort ,abort))))
 304     #-win32
 305     (frob (process-pty process) t)   ; Don't FLUSH-OUTPUT to dead process,
 306     (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE.
 307     (frob (process-output process) nil)
 308     (frob (process-error process) nil))
 309   ;; FIXME: Given that the status-slot is no longer updated,
 310   ;; maybe it should be set to :CLOSED, or similar?
 311   (with-active-processes-lock ()
 312    (setf *active-processes* (delete process *active-processes*)))
 313   #+win32
 314   (let ((handle (shiftf (process-handle process) nil)))
 315     (when handle
 316       (or (plusp (sb-win32:close-handle handle))
 317           (sb-win32::win32-error 'process-close))))
 318   process)
 319
 320 (defun get-processes-status-changes ()
 321   (let (changed)
 322     (with-active-processes-lock ()
 323       (setf *active-processes*
 324             (delete-if #-win32
 325                        (lambda (proc)
 326                          ;; Wait only on pids belonging to processes
 327                          ;; started by RUN-PROGRAM. There used to be a
 328                          ;; WAIT3 call here, but that makes direct
 329                          ;; WAIT, WAITPID usage impossible due to the
 330                          ;; race with the SIGCHLD signal handler.
 331                          (multiple-value-bind (status code core)
 332                              (waitpid (process-pid proc))
 333                            (when status
 334                              (setf (process-%status proc) status)
 335                              (setf (process-%exit-code proc) code)
 336                              (when (process-status-hook proc)
 337                                (push proc changed))
 338                              (when (member status '(:exited :signaled))
 339                                (setf (process-core-dumped proc) core)
 340                                t))))
 341                        #+win32
 342                        (lambda (proc)
 343                          (let ((handle (process-handle proc)))
 344                            (when handle
 345                              (multiple-value-bind (ok code)
 346                                  (sb-win32::get-exit-code-process handle)
 347                                (when (and (plusp ok)
 348                                           (/= code sb-win32::still-active))
 349                                  (setf (process-%status proc) :exited
 350                                        (process-%exit-code proc) code)
 351                                  (sb-win32::close-handle handle)
 352                                  (setf (process-handle proc) nil)
 353                                  (when (process-status-hook proc)
 354                                    (push proc changed))
 355                                  t)))))
 356                        *active-processes*)))
 357     ;; Can't call the hooks before all the processes have been deal
 358     ;; with, as calling a hook may cause re-entry to
 359     ;; GET-PROCESS-STATUS-CHANGES. That may be OK when using waitpid,
 360     ;; but in the Windows implementation it would be deeply bad.
 361     (dolist (proc changed)
 362       (let ((hook (process-status-hook proc)))
 363         (funcall hook proc)))))
 364 \f
 365 ;;;; RUN-PROGRAM and close friends
 366
 367 ;;; list of file descriptors to close when RUN-PROGRAM exits due to an error
 368 (defvar *close-on-error* nil)
 369
 370 ;;; list of file descriptors to close when RUN-PROGRAM returns in the parent
 371 (defvar *close-in-parent* nil)
 372
 373 ;;; list of handlers installed by RUN-PROGRAM.
 374 (defvar *handlers-installed* nil)
 375
 376 ;;; Find an unused pty. Return three values: the file descriptor for
 377 ;;; the master side of the pty, the file descriptor for the slave side
 378 ;;; of the pty, and the name of the tty device for the slave side.
 379 #-(or win32 openbsd freebsd dragonfly)
 380 (progn
 381   (define-alien-routine ptsname c-string (fd int))
 382   (define-alien-routine grantpt boolean (fd int))
 383   (define-alien-routine unlockpt boolean (fd int))
 384
 385   (defun find-a-pty ()
 386     ;; First try to use the Unix98 pty api.
 387     (let* ((master-name (coerce (format nil "/dev/ptmx") 'base-string))
 388            (master-fd (sb-unix:unix-open master-name
 389                                          (logior sb-unix:o_rdwr
 390                                                  sb-unix:o_noctty)
 391                                          #o666)))
 392       (when master-fd
 393         (grantpt master-fd)
 394         (unlockpt master-fd)
 395         (let* ((slave-name (ptsname master-fd))
 396                (slave-fd (sb-unix:unix-open slave-name
 397                                             (logior sb-unix:o_rdwr
 398                                                     sb-unix:o_noctty)
 399                                             #o666)))
 400           (when slave-fd
 401             (return-from find-a-pty
 402               (values master-fd
 403                       slave-fd
 404                       slave-name)))
 405           (sb-unix:unix-close master-fd))
 406         (error "could not find a pty")))
 407     ;; No dice, try using the old-school method.
 408     (dolist (char '(#\p #\q))
 409       (dotimes (digit 16)
 410         (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit)
 411                                     'base-string))
 412                (master-fd (sb-unix:unix-open master-name
 413                                              (logior sb-unix:o_rdwr
 414                                                      sb-unix:o_noctty)
 415                                              #o666)))
 416           (when master-fd
 417             (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit)
 418                                        'base-string))
 419                    (slave-fd (sb-unix:unix-open slave-name
 420                                                 (logior sb-unix:o_rdwr
 421                                                         sb-unix:o_noctty)
 422                                                 #o666)))
 423               (when slave-fd
 424                 (return-from find-a-pty
 425                   (values master-fd
 426                           slave-fd
 427                           slave-name)))
 428               (sb-unix:unix-close master-fd))))))
 429     (error "could not find a pty")))
 430
 431 #+(or openbsd freebsd dragonfly)
 432 (progn
 433   (define-alien-routine openpty int (amaster int :out) (aslave int :out)
 434                         (name (* char)) (termp (* t)) (winp (* t)))
 435   (defun find-a-pty ()
 436     (with-alien ((name-buf (array char #.path-max)))
 437       (multiple-value-bind (return-val master-fd slave-fd)
 438           (openpty (cast name-buf (* char)) nil nil)
 439         (if (zerop return-val)
 440             (values master-fd
 441                     slave-fd
 442                     (sb-alien::c-string-to-string (alien-sap name-buf)
 443                                                   (sb-impl::default-external-format)
 444                                                   'character))
 445             (error "could not find a pty"))))))
 446
 447 #-win32
 448 (defun open-pty (pty cookie &key (external-format :default))
 449   (when pty
 450     (multiple-value-bind
 451           (master slave name)
 452         (find-a-pty)
 453       (push master *close-on-error*)
 454       (push slave *close-in-parent*)
 455       (when (streamp pty)
 456         (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
 457           (unless new-fd
 458             (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno)))
 459           (push new-fd *close-on-error*)
 460           (copy-descriptor-to-stream new-fd pty cookie external-format)))
 461       (values name
 462               (make-fd-stream master :input t :output t
 463                                      :external-format external-format
 464                                      :element-type :default
 465                                      :dual-channel-p t)))))
 466
 467 ;; Null terminate strings only C-side: otherwise we can run into
 468 ;; A-T-S-L even for simple encodings like ASCII.  Multibyte encodings
 469 ;; may need more than a single byte of zeros; assume 4 byte is enough
 470 ;; for everyone.
 471 #-win32
 472 (defmacro round-null-terminated-bytes-to-words (n)
 473   `(logandc2 (the sb-vm:signed-word (+ (the fixnum ,n)
 474                                        4 (1- sb-vm:n-machine-word-bytes)))
 475              (1- sb-vm:n-machine-word-bytes)))
 476
 477 #-win32
 478 (defun string-list-to-c-strvec (string-list)
 479   (let* (;; We need an extra for the null, and an extra 'cause exect
 480          ;; clobbers argv[-1].
 481          (vec-bytes (* sb-vm:n-machine-word-bytes (+ (length string-list) 2)))
 482          (octet-vector-list (mapcar (lambda (s)
 483                                       (string-to-octets s))
 484                                     string-list))
 485          (string-bytes (reduce #'+ octet-vector-list
 486                                :key (lambda (s)
 487                                       (round-null-terminated-bytes-to-words
 488                                        (length s)))))
 489          (total-bytes (+ string-bytes vec-bytes))
 490          ;; Memory to hold the vector of pointers and all the strings.
 491          (vec-sap (allocate-system-memory total-bytes))
 492          (string-sap (sap+ vec-sap vec-bytes))
 493          ;; Index starts from [1]!
 494          (vec-index-offset sb-vm:n-machine-word-bytes))
 495     (declare (sb-vm:signed-word vec-bytes)
 496              (sb-vm:word string-bytes total-bytes)
 497              (system-area-pointer vec-sap string-sap))
 498     (dolist (octets octet-vector-list)
 499       (declare (type (simple-array (unsigned-byte 8) (*)) octets))
 500       (let ((size (length octets)))
 501         ;; Copy string.
 502         (sb-kernel:copy-ub8-to-system-area octets 0 string-sap 0 size)
 503         ;; NULL-terminate it
 504         (sb-kernel:system-area-ub8-fill 0 string-sap size 4)
 505         ;; Put the pointer in the vector.
 506         (setf (sap-ref-sap vec-sap vec-index-offset) string-sap)
 507         ;; Advance string-sap for the next string.
 508         (setf string-sap (sap+ string-sap
 509                                (round-null-terminated-bytes-to-words size)))
 510         (incf vec-index-offset sb-vm:n-machine-word-bytes)))
 511     ;; Final null pointer.
 512     (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0))
 513     (values vec-sap (sap+ vec-sap sb-vm:n-machine-word-bytes) total-bytes)))
 514
 515 #-win32
 516 (defmacro with-args ((var str-list) &body body)
 517   (with-unique-names (sap size)
 518     `(multiple-value-bind (,sap ,var ,size)
 519          (string-list-to-c-strvec ,str-list)
 520        (unwind-protect
 521             (progn
 522               ,@body)
 523          (deallocate-system-memory ,sap ,size)))))
 524
 525 (defmacro with-environment ((var str-list &key null) &body body)
 526   (once-only ((null null))
 527     (with-unique-names (sap size)
 528       `(multiple-value-bind (,sap ,var ,size)
 529            (if ,null
 530                (values nil (int-sap 0))
 531                #-win32 (string-list-to-c-strvec ,str-list)
 532                #+win32 (encode-windows-environment ,str-list))
 533          (unwind-protect
 534               (progn
 535                 ,@body)
 536            (unless ,null
 537              (deallocate-system-memory ,sap ,size)))))))
 538 #-win32
 539 (define-alien-routine spawn
 540      int
 541   (program c-string)
 542   (argv (* c-string))
 543   (stdin int)
 544   (stdout int)
 545   (stderr int)
 546   (search int)
 547   (envp (* c-string))
 548   (pty-name c-string)
 549   (wait int)
 550   (dir c-string))
 551
 552 #+win32
 553 (defun escape-arg (arg stream)
 554   ;; Normally, #\\ doesn't have to be escaped
 555   ;; But if #\" follows #\\, then they have to be escaped.
 556   ;; Do that by counting the number of consequent backslashes, and
 557   ;; upon encoutering #\" immediately after them, output the same
 558   ;; number of backslashes, plus one for #\"
 559   (write-char #\" stream)
 560   (loop with slashes = 0
 561         for i below (length arg)
 562         for previous-char = #\a then char
 563         for char = (char arg i)
 564         do
 565         (case char
 566           (#\"
 567            (loop repeat slashes
 568                  do (write-char #\\ stream))
 569            (write-string "\\\"" stream))
 570           (t
 571            (write-char char stream)))
 572         (case char
 573           (#\\
 574            (incf slashes))
 575           (t
 576            (setf slashes 0)))
 577         finally
 578         ;; The final #\" counts too, but doesn't need to be escaped itself
 579         (loop repeat slashes
 580               do (write-char #\\ stream)))
 581   (write-char #\" stream))
 582
 583 #+win32
 584 (defun prepare-args (args escape)
 585   (with-simple-output-to-string (str)
 586     (loop for (arg . rest) on args
 587           do
 588           (cond ((and escape
 589                       (find-if (lambda (c) (find c '(#\Space #\Tab #\")))
 590                                arg))
 591                  (escape-arg arg str))
 592                 (t
 593                  (write-string arg str)))
 594           (when rest
 595             (write-char #\Space str)))))
 596
 597 #-win32
 598 (defun prepare-args (args)
 599   (if (every #'simple-string-p args)
 600       args
 601       (loop for arg in args
 602             collect (coerce arg 'simple-string))))
 603
 604 ;;; FIXME: There shouldn't be two semiredundant versions of the
 605 ;;; documentation. Since this is a public extension function, the
 606 ;;; documentation should be in the doc string. So all information from
 607 ;;; this comment should be merged into the doc string, and then this
 608 ;;; comment can go away.
 609 ;;;
 610 ;;; RUN-PROGRAM uses fork() and execve() to run a different program.
 611 ;;; Strange stuff happens to keep the Unix state of the world
 612 ;;; coherent.
 613 ;;;
 614 ;;; The child process needs to get its input from somewhere, and send
 615 ;;; its output (both standard and error) to somewhere. We have to do
 616 ;;; different things depending on where these somewheres really are.
 617 ;;;
 618 ;;; For input, there are five options:
 619 ;;;  -- T: Just leave fd 0 alone. Pretty simple.
 620 ;;;  -- "file": Read from the file. We need to open the file and
 621 ;;;     pull the descriptor out of the stream. The parent should close
 622 ;;;     this stream after the child is up and running to free any
 623 ;;;     storage used in the parent.
 624 ;;;  -- NIL: Same as "file", but use "/dev/null" as the file.
 625 ;;;  -- :STREAM: Use Unix pipe() to create two descriptors. Use
 626 ;;;     SB-SYS:MAKE-FD-STREAM to create the output stream on the
 627 ;;;     writeable descriptor, and pass the readable descriptor to
 628 ;;;     the child. The parent must close the readable descriptor for
 629 ;;;     EOF to be passed up correctly.
 630 ;;;  -- a stream: If it's a fd-stream, just pull the descriptor out
 631 ;;;     of it. Otherwise make a pipe as in :STREAM, and copy
 632 ;;;     everything across.
 633 ;;;
 634 ;;; For output, there are five options:
 635 ;;;  -- T: Leave descriptor 1 alone.
 636 ;;;  -- "file": dump output to the file.
 637 ;;;  -- NIL: dump output to /dev/null.
 638 ;;;  -- :STREAM: return a stream that can be read from.
 639 ;;;  -- a stream: if it's a fd-stream, use the descriptor in it.
 640 ;;;     Otherwise, copy stuff from output to stream.
 641 ;;;
 642 ;;; For error, there are all the same options as output plus:
 643 ;;;  -- :OUTPUT: redirect to the same place as output.
 644 ;;;
 645 ;;; RUN-PROGRAM returns a PROCESS structure for the process if
 646 ;;; the fork worked, and NIL if it did not.
 647 (defun run-program (program args
 648                     &key
 649                     (env nil env-p)
 650                     (environment
 651                      (when env-p
 652                        (unix-environment-sbcl-from-cmucl env))
 653                      environment-p)
 654                     (wait t)
 655                     search
 656                     #-win32 pty
 657                     input
 658                     if-input-does-not-exist
 659                     output
 660                     (if-output-exists :error)
 661                     (error :output)
 662                     (if-error-exists :error)
 663                     status-hook
 664                     (external-format :default)
 665                     directory
 666                     #+win32 (escape-arguments t))
 667   #.(concatenate
 668      'base-string
 669      ;; The Texinfoizer is sensitive to whitespace, so mind the
 670      ;; placement of the #-win32 pseudosplicings.
 671      "RUN-PROGRAM creates a new process specified by the PROGRAM
 672 argument. ARGS are the standard arguments that can be passed to a
 673 program. For no arguments, use NIL (which means that just the
 674 name of the program is passed as arg 0).
 675
 676 The program arguments and the environment are encoded using the
 677 default external format for streams.
 678
 679 RUN-PROGRAM will return a PROCESS structure. See the CMU Common Lisp
 680 Users Manual for details about the PROCESS structure.
 681
 682    Notes about Unix environments (as in the :ENVIRONMENT and :ENV args):
 683
 684    - The SBCL implementation of RUN-PROGRAM, like Perl and many other
 685      programs, but unlike the original CMU CL implementation, copies
 686      the Unix environment by default."#-win32"
 687    - Running Unix programs from a setuid process, or in any other
 688      situation where the Unix environment is under the control of someone
 689      else, is a mother lode of security problems. If you are contemplating
 690      doing this, read about it first. (The Perl community has a lot of good
 691      documentation about this and other security issues in script-like
 692      programs.)""
 693
 694    The &KEY arguments have the following meanings:
 695    :ENVIRONMENT
 696       a list of STRINGs describing the new Unix environment
 697       (as in \"man environ\"). The default is to copy the environment of
 698       the current process.
 699    :ENV
 700       an alternative lossy representation of the new Unix environment,
 701       for compatibility with CMU CL
 702    :SEARCH
 703       Look for PROGRAM in each of the directories in the child's $PATH
 704       environment variable.  Otherwise an absolute pathname is required.
 705    :WAIT
 706       If non-NIL (default), wait until the created process finishes.  If
 707       NIL, continue running Lisp until the program finishes."#-win32"
 708    :PTY
 709       Either T, NIL, or a stream.  Unless NIL, the subprocess is established
 710       under a PTY.  If :pty is a stream, all output to this pty is sent to
 711       this stream, otherwise the PROCESS-PTY slot is filled in with a stream
 712       connected to pty that can read output and write input.""
 713    :INPUT
 714       Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
 715       input for the current process is inherited.  If NIL, "
 716       #-win32"/dev/null"#+win32"nul""
 717       is used.  If a pathname, the file so specified is used.  If a stream,
 718       all the input is read from that stream and sent to the subprocess.  If
 719       :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
 720       its output to the process. Defaults to NIL.
 721    :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
 722       can be one of:
 723          :ERROR to generate an error
 724          :CREATE to create an empty file
 725          NIL (the default) to return NIL from RUN-PROGRAM
 726    :OUTPUT
 727       Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
 728       output for the current process is inherited.  If NIL, "
 729       #-win32"/dev/null"#+win32"nul""
 730       is used.  If a pathname, the file so specified is used.  If a stream,
 731       all the output from the process is written to this stream. If
 732       :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
 733       be read to get the output. Defaults to NIL.
 734    :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
 735       can be one of:
 736          :ERROR (the default) to generate an error
 737          :SUPERSEDE to supersede the file with output from the program
 738          :APPEND to append output from the program to the file
 739          NIL to return NIL from RUN-PROGRAM, without doing anything
 740    :ERROR and :IF-ERROR-EXISTS
 741       Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
 742       specified as :OUTPUT in which case all error output is routed to the
 743       same place as normal output.
 744    :STATUS-HOOK
 745       This is a function the system calls whenever the status of the
 746       process changes.  The function takes the process as an argument.
 747    :EXTERNAL-FORMAT
 748       The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs.
 749    :DIRECTORY
 750       Specifies the directory in which the program should be run.
 751       NIL (the default) means the directory is unchanged.
 752
 753    Windows specific options:
 754    :ESCAPE-ARGUMENTS (default T)
 755       Controls escaping of the arguments passed to CreateProcess.")
 756   (when (and env-p environment-p)
 757     (error "can't specify :ENV and :ENVIRONMENT simultaneously"))
 758   (let* (;; Clear various specials used by GET-DESCRIPTOR-FOR to
 759          ;; communicate cleanup info.
 760          *close-on-error*
 761          *close-in-parent*
 762          *handlers-installed*
 763          ;; Establish PROC at this level so that we can return it.
 764          proc
 765          (progname (native-namestring program))
 766          (args (prepare-args (cons progname args) #+win32 escape-arguments))
 767          (directory (and directory (native-namestring directory)))
 768          ;; Gag.
 769          (cookie (list 0)))
 770     (unwind-protect
 771          ;; Note: despite the WITH-* names, these macros don't
 772          ;; expand into UNWIND-PROTECT forms.  They're just
 773          ;; syntactic sugar to make the rest of the routine slightly
 774          ;; easier to read.
 775          (macrolet ((with-fd-and-stream-for (((fd stream) which &rest args)
 776                                              &body body)
 777                       `(multiple-value-bind (,fd ,stream)
 778                            ,(ecase which
 779                               ((:input :output)
 780                                `(get-descriptor-for ,which ,@args))
 781                               (:error
 782                                `(if (eq ,(first args) :output)
 783                                     ;; kludge: we expand into
 784                                     ;; hard-coded symbols here.
 785                                     (values stdout output-stream)
 786                                     (get-descriptor-for ,which ,@args))))
 787                          (unless ,fd
 788                            (return-from run-program))
 789                          ,@body))
 790                     (with-open-pty (((pty-name pty-stream) (pty cookie))
 791                                     &body body)
 792                       (declare (ignorable pty-name pty-stream pty cookie))
 793                       #+win32
 794                       `(progn ,@body)
 795                       #-win32
 796                       `(multiple-value-bind (,pty-name ,pty-stream)
 797                            (open-pty ,pty ,cookie :external-format external-format)
 798                          ,@body)))
 799            (with-fd-and-stream-for ((stdin input-stream) :input
 800                                     input cookie
 801                                     :direction :input
 802                                     :if-does-not-exist if-input-does-not-exist
 803                                     :external-format external-format
 804                                     :wait wait)
 805              (with-fd-and-stream-for ((stdout output-stream) :output
 806                                       output cookie
 807                                       :direction :output
 808                                       :if-exists if-output-exists
 809                                       :external-format external-format)
 810                (with-fd-and-stream-for ((stderr error-stream)  :error
 811                                         error cookie
 812                                         :direction :output
 813                                         :if-exists if-error-exists
 814                                         :external-format external-format)
 815                  (with-open-pty ((pty-name pty-stream) (pty cookie))
 816                    ;; Make sure we are not notified about the child
 817                    ;; death before we have installed the PROCESS
 818                    ;; structure in *ACTIVE-PROCESSES*.
 819                    (let (child #+win32 handle)
 820                      (with-active-processes-lock ()
 821                        (with-environment (environment-vec environment
 822                                           :null (not (or environment environment-p)))
 823                          (setf (values child #+win32 handle)
 824                                #+win32
 825                                (sb-win32::mswin-spawn
 826                                 progname
 827                                 args
 828                                 stdin stdout stderr
 829                                 search environment-vec directory)
 830                                #-win32
 831                                (with-args (args-vec args)
 832                                  (without-gcing
 833                                    (spawn progname args-vec
 834                                           stdin stdout stderr
 835                                           (if search 1 0)
 836                                           environment-vec pty-name
 837                                           (if wait 1 0) directory))))
 838                          (unless (minusp child)
 839                            (setf proc
 840                                  (make-process
 841                                   :input input-stream
 842                                   :output output-stream
 843                                   :error error-stream
 844                                   :status-hook status-hook
 845                                   :cookie cookie
 846                                   #-win32 :pty #-win32 pty-stream
 847                                   :%status :running
 848                                   :pid child
 849                                   #+win32 :copiers #+win32 *handlers-installed*
 850                                   #+win32 :handle #+win32 handle))
 851                            (push proc *active-processes*))))
 852                      ;; Report the error outside the lock.
 853                      (case child
 854                        (-1
 855                         (error "Couldn't fork child process: ~A"
 856                                (strerror)))
 857                        (-2
 858                         (error "Couldn't execute ~S: ~A"
 859                                progname (strerror)))
 860                        (-3
 861                         (error "Couldn't change directory to ~S: ~A"
 862                                directory (strerror))))))))))
 863       (dolist (fd *close-in-parent*)
 864         (sb-unix:unix-close fd))
 865       (unless proc
 866         (dolist (fd *close-on-error*)
 867           (sb-unix:unix-close fd))
 868         #-win32
 869         (dolist (handler *handlers-installed*)
 870           (remove-fd-handler handler)))
 871       (when (and wait proc)
 872         (unwind-protect
 873              (process-wait proc)
 874           #-win32
 875           (dolist (handler *handlers-installed*)
 876             (remove-fd-handler handler)))))
 877     proc))
 878
 879 ;;; Install a handler for any input that shows up on the file
 880 ;;; descriptor. The handler reads the data and writes it to the
 881 ;;; stream.
 882 #-win32
 883 (defun copy-descriptor-to-stream (descriptor stream cookie external-format)
 884   (incf (car cookie))
 885   (let* ((handler nil)
 886          (buf (make-array 256 :element-type '(unsigned-byte 8)))
 887          (read-end 0)
 888          (et (stream-element-type stream))
 889          (copy-fun
 890           (cond
 891             ((member et '(character base-char))
 892              (lambda ()
 893                (let* ((decode-end read-end)
 894                       (string (handler-case
 895                                   (octets-to-string
 896                                    buf :end read-end
 897                                    :external-format external-format)
 898                                 (end-of-input-in-character (e)
 899                                   (setf decode-end
 900                                         (octet-decoding-error-start e))
 901                                   (octets-to-string
 902                                    buf :end decode-end
 903                                    :external-format external-format)))))
 904                  (unless (zerop (length string))
 905                    (write-string string stream)
 906                    (when (/= decode-end (length buf))
 907                      (replace buf buf :start2 decode-end :end2 read-end))
 908                    (decf read-end decode-end)))))
 909             (t
 910              (lambda ()
 911                (handler-bind
 912                    ((type-error
 913                       (lambda (c)
 914                         (error 'simple-type-error
 915                                          :format-control
 916                                          "Error using ~s for program output:~@
 917                                           ~a"
 918                                          :format-arguments
 919                                          (list stream c)
 920                                          :expected-type
 921                                          (type-error-expected-type c)
 922                                          :datum
 923                                          (type-error-datum c)))))
 924                  (write-sequence buf stream :end read-end))
 925                (setf read-end 0))))))
 926     (setf handler
 927           (add-fd-handler
 928            descriptor
 929            :input
 930            (lambda (fd)
 931              (declare (ignore fd))
 932              (loop
 933                 (unless handler
 934                   (return))
 935                 (multiple-value-bind
 936                       (result readable/errno)
 937                     (sb-unix:unix-select (1+ descriptor)
 938                                          (ash 1 descriptor)
 939                                          0 0 0)
 940                   (cond ((null result)
 941                          (if (eql sb-unix:eintr readable/errno)
 942                              (return)
 943                              (error "~@<Couldn't select on sub-process: ~
 944                                         ~2I~_~A~:>"
 945                                     (strerror readable/errno))))
 946                         ((zerop result)
 947                          (return))))
 948                 (multiple-value-bind (count errno)
 949                     (with-pinned-objects (buf)
 950                       (sb-unix:unix-read descriptor
 951                                          (sap+ (vector-sap buf) read-end)
 952                                          (- (length buf) read-end)))
 953                   (cond
 954                     ((and #-win32 (or (and (null count)
 955                                            (eql errno sb-unix:eio))
 956                                       (eql count 0))
 957                           #+win32 (<= count 0))
 958                      (remove-fd-handler handler)
 959                      (setf handler nil)
 960                      (decf (car cookie))
 961                      (sb-unix:unix-close descriptor)
 962                      (unless (zerop read-end)
 963                        ;; Should this be an END-OF-FILE?
 964                        (error "~@<non-empty buffer when EOF reached ~
 965                                while reading from child: ~S~:>" buf))
 966                      (return))
 967                     ((null count)
 968                      (remove-fd-handler handler)
 969                      (setf handler nil)
 970                      (decf (car cookie))
 971                      (error
 972                       "~@<couldn't read input from sub-process: ~
 973                                      ~2I~_~A~:>"
 974                       (strerror errno)))
 975                     (t
 976                      (incf read-end count)
 977                      (funcall copy-fun))))))))
 978     (push handler *handlers-installed*)))
 979
 980 #+win32
 981 (defun copy-descriptor-to-stream (descriptor stream cookie external-format)
 982   (declare (ignore cookie))
 983   (push (sb-win32::make-io-copier :pipe descriptor
 984                                   :stream stream
 985                                   :external-format external-format)
 986         *handlers-installed*))
 987
 988 ;;; FIXME: something very like this is done in SB-POSIX to treat
 989 ;;; streams as file descriptor designators; maybe we can combine these
 990 ;;; two?  Additionally, as we have a couple of user-defined streams
 991 ;;; libraries, maybe we should have a generic function for doing this,
 992 ;;; so user-defined streams can play nicely with RUN-PROGRAM (and
 993 ;;; maybe also with SB-POSIX)?
 994 (defun get-stream-fd-and-external-format (stream direction)
 995   (typecase stream
 996     (fd-stream
 997      (values (fd-stream-fd stream) nil (stream-external-format stream)))
 998     (synonym-stream
 999      (get-stream-fd-and-external-format
1000       (resolve-synonym-stream stream) direction))
1001     (two-way-stream
1002      (ecase direction
1003        (:input
1004         (get-stream-fd-and-external-format
1005          (two-way-stream-input-stream stream) direction))
1006        (:output
1007         (get-stream-fd-and-external-format
1008          (two-way-stream-output-stream stream) direction))))))
1009
1010 (defun get-temporary-directory ()
1011   #-win32 (or (sb-ext:posix-getenv "TMPDIR")
1012               "/tmp")
1013   #+win32 (or (sb-ext:posix-getenv "TEMP")
1014               "C:/Temp"))
1015
1016 \f
1017 ;;; Find a file descriptor to use for object given the direction.
1018 ;;; Returns the descriptor. If object is :STREAM, returns the created
1019 ;;; stream as the second value.
1020 (defun get-descriptor-for (argument object cookie
1021                            &rest keys
1022                            &key direction (external-format :default) wait
1023                            &allow-other-keys)
1024   (declare (ignore wait)) ;This is explained below.
1025   ;; Our use of a temporary file dates back to very old CMUCLs, and
1026   ;; was probably only ever intended for use with STRING-STREAMs,
1027   ;; which are ordinarily smallish.  However, as we've got
1028   ;; user-defined stream classes, we can end up trying to copy
1029   ;; arbitrarily much data into the temp file, and so are liable to
1030   ;; run afoul of disk quotas or to choke on small /tmp file systems.
1031   (labels ((fail (format &rest arguments)
1032              (error "~s error processing ~s argument:~% ~?" 'run-program argument format arguments))
1033            (make-temp-fd ()
1034              (multiple-value-bind (fd name/errno)
1035                  (sb-unix:sb-mkstemp (format nil "~a/.run-program-XXXXXX"
1036                                              (get-temporary-directory))
1037                                      #o0600)
1038                (unless fd
1039                  (fail "could not open a temporary file: ~A"
1040                        (strerror name/errno)))
1041                #+win32
1042                (setf (sb-win32::inheritable-handle-p fd) t)
1043                ;; Can't unlink an open file on Windows
1044                #-win32
1045                (unless (sb-unix:unix-unlink name/errno)
1046                  (sb-unix:unix-close fd)
1047                  (fail "failed to unlink ~A" name/errno))
1048                fd)))
1049     (let ((dev-null #.(coerce #-win32 "/dev/null" #+win32 "nul" 'base-string)))
1050       (cond ((eq object t)
1051              ;; No new descriptor is needed.
1052              (values -1 nil))
1053             ((or (eq object nil)
1054                  (and (typep object 'broadcast-stream)
1055                       (not (broadcast-stream-streams object))))
1056              ;; Use /dev/null.
1057              (multiple-value-bind
1058                    (fd errno)
1059                  (sb-unix:unix-open dev-null
1060                                     (case direction
1061                                       (:input sb-unix:o_rdonly)
1062                                       (:output sb-unix:o_wronly)
1063                                       (t sb-unix:o_rdwr))
1064                                     #o666
1065                                     #+win32 :overlapped #+win32 nil)
1066                (unless fd
1067                  (fail "~@<couldn't open ~S: ~2I~_~A~:>"
1068                        dev-null (strerror errno)))
1069                #+win32
1070                (setf (sb-win32::inheritable-handle-p fd) t)
1071                (push fd *close-in-parent*)
1072                (values fd nil)))
1073             ((eq object :stream)
1074              (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe)
1075                (unless read-fd
1076                  (fail "couldn't create pipe: ~A" (strerror write-fd)))
1077                #+win32
1078                (setf (sb-win32::inheritable-handle-p read-fd)
1079                      (eq direction :input)
1080                      (sb-win32::inheritable-handle-p write-fd)
1081                      (eq direction :output))
1082                (case direction
1083                  (:input
1084                     (push read-fd *close-in-parent*)
1085                     (push write-fd *close-on-error*)
1086                     (let ((stream (make-fd-stream write-fd :output t
1087                                                          :element-type :default
1088                                                          :external-format
1089                                                          external-format)))
1090                       (values read-fd stream)))
1091                  (:output
1092                     (push read-fd *close-on-error*)
1093                     (push write-fd *close-in-parent*)
1094                     (let ((stream (make-fd-stream read-fd :input t
1095                                                          :element-type :default
1096                                                          :external-format
1097                                                          external-format)))
1098                       (values write-fd stream)))
1099                  (t
1100                     (sb-unix:unix-close read-fd)
1101                     (sb-unix:unix-close write-fd)
1102                     (fail "Direction must be either :INPUT or :OUTPUT, not ~S."
1103                            direction)))))
1104             ((or (pathnamep object) (stringp object))
1105              ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather
1106              ;; than munge the &rest list for OPEN, just disable keyword
1107              ;; validation there.
1108              (with-open-stream (file (or (apply #'open object
1109                                                 :allow-other-keys t
1110                                                 #+win32 :overlapped #+win32 nil
1111                                                 keys)
1112                                          ;; :if-input-does-not-exist nil
1113                                          ;; can result in this
1114                                          (return-from get-descriptor-for)))
1115                (multiple-value-bind
1116                      (fd errno)
1117                    (sb-unix:unix-dup (fd-stream-fd file))
1118                  (cond (fd
1119                         (push fd *close-in-parent*)
1120                         (values fd nil))
1121                        (t
1122                         (fail "couldn't duplicate file descriptor: ~A"
1123                               (strerror errno)))))))
1124           ((streamp object)
1125            (ecase direction
1126              (:input
1127               (block nil
1128                 ;; If we can get an fd for the stream, let the child
1129                 ;; process use the fd for its descriptor.  Otherwise,
1130                 ;; we copy data from the stream into a temp file, and
1131                 ;; give the temp file's descriptor to the
1132                 ;; child.
1133                 (multiple-value-bind (fd stream format)
1134                     (get-stream-fd-and-external-format object :input)
1135                   (declare (ignore format))
1136                   (when fd
1137                     (return (values fd stream))))
1138                 ;; FIXME: if we can't get the file descriptor, since
1139                 ;; the stream might be interactive or otherwise
1140                 ;; block-y, we can't know whether we can copy the
1141                 ;; stream's data to a temp file, so if RUN-PROGRAM was
1142                 ;; called with :WAIT NIL, we should probably error.
1143                 ;; However, STRING-STREAMs aren't fd-streams, but
1144                 ;; they're not prone to blocking; any user-defined
1145                 ;; streams that "read" from some in-memory data will
1146                 ;; probably be similar to STRING-STREAMs.  So maybe we
1147                 ;; should add a STREAM-INTERACTIVE-P generic function
1148                 ;; for problems like this?  Anyway, the machinery is
1149                 ;; here, if you feel like filling in the details.
1150                 #|
1151                 (when (and (null wait) #<some undetermined criterion>)
1152                   (error "~@<don't know how to get an fd for ~A, and so ~
1153                              can't ensure that copying its data to the ~
1154                              child process won't hang~:>" object))
1155                 |#
1156                 (let ((fd (make-temp-fd))
1157                       (et (stream-element-type object)))
1158                   (cond ((member et '(character base-char))
1159                          (loop
1160                            (multiple-value-bind
1161                                  (line no-cr)
1162                                (read-line object nil nil)
1163                              (unless line
1164                                (return))
1165                              (let ((vector (string-to-octets
1166                                             line
1167                                             :external-format external-format)))
1168                                (sb-unix:unix-write
1169                                 fd vector 0 (length vector)))
1170                              (if no-cr
1171                                (return)
1172                                (sb-unix:unix-write
1173                                 fd #.(string #\Newline) 0 1)))))
1174                         (t
1175                          (handler-bind
1176                              ((type-error
1177                                 (lambda (c)
1178                                   (error 'simple-type-error
1179                                          :format-control
1180                                          "Error using ~s for program input:~@
1181                                           ~a"
1182                                          :format-arguments
1183                                          (list object c)
1184                                          :expected-type
1185                                          (type-error-expected-type c)
1186                                          :datum
1187                                          (type-error-datum c)))))
1188                            (loop with buf = (make-array 256 :element-type '(unsigned-byte 8))
1189                                  for p = (read-sequence buf object)
1190                                  until (zerop p)
1191                                  do (sb-unix:unix-write fd buf 0 p)))))
1192                   (sb-unix:unix-lseek fd 0 sb-unix:l_set)
1193                   (push fd *close-in-parent*)
1194                   (return (values fd nil)))))
1195              (:output
1196               (block nil
1197                 ;; Similar to the :input trick above, except we
1198                 ;; arrange to copy data from the stream.  This is
1199                 ;; slightly saner than the input case, since we don't
1200                 ;; buffer to a file, but I think we may still lose if
1201                 ;; there's unflushed data in the stream buffer and we
1202                 ;; give the file descriptor to the child.
1203                 (multiple-value-bind (fd stream format)
1204                     (get-stream-fd-and-external-format object :output)
1205                   (declare (ignore format))
1206                   (when fd
1207                     (return (values fd stream))))
1208                 (multiple-value-bind (read-fd write-fd)
1209                     #-win32 (sb-unix:unix-pipe)
1210                     #+win32 (sb-win32::make-named-pipe)
1211                   (unless read-fd
1212                     (fail "couldn't create pipe: ~S" (strerror write-fd)))
1213                   #+win32
1214                   (setf (sb-win32::inheritable-handle-p write-fd) t)
1215                   (copy-descriptor-to-stream read-fd object cookie
1216                                              external-format)
1217                   (push read-fd *close-on-error*)
1218                   (push write-fd *close-in-parent*)
1219                   (return (values write-fd nil)))))))
1220           (t
1221            (fail "invalid option: ~S" object))))))