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