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