X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=eb9aa47ea8c19bed7a4b9b58eb4627fab5e0e34a;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=d704435e7d8f2716974be2ef8eb96022ee40493a;hpb=8fc5fda05f92d69c95b47e4ad7561d91dab18c3e;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index d704435..eb9aa47 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -10,334 +10,636 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-EXT") +(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) + +;;;; hacking the Unix environment +;;;; +;;;; In the original CMU CL code that LOAD-FOREIGN is derived from, the +;;;; Unix environment (as in "man environ") was represented as an +;;;; alist from keywords to strings, so that e.g. the Unix environment +;;;; "SHELL=/bin/bash" "HOME=/root" "PAGER=less" +;;;; was represented as +;;;; ((:SHELL . "/bin/bash") (:HOME . "/root") (:PAGER "less")) +;;;; This had a few problems in principle: the mapping into +;;;; keyword symbols smashed the case of environment +;;;; variables, and the whole mapping depended on the presence of +;;;; #\= characters in the environment strings. In practice these +;;;; problems weren't hugely important, since conventionally environment +;;;; variables are uppercase strings followed by #\= followed by +;;;; arbitrary data. However, since it's so manifestly not The Right +;;;; Thing to make code which breaks unnecessarily on input which +;;;; doesn't follow what is, after all, only a tradition, we've switched +;;;; formats in SBCL, so that the fundamental environment list +;;;; is just a list of strings, with a one-to-one-correspondence +;;;; to the C-level representation. I.e., in the example above, +;;;; the SBCL representation is +;;;; '("SHELL=/bin/bash" "HOME=/root" "PAGER=less") +;;;; CMU CL's implementation is currently supported to help with porting. +;;;; +;;;; It's not obvious that this code belongs here (instead of e.g. in +;;;; unix.lisp), since it has only a weak logical connection with +;;;; RUN-PROGRAM. However, physically it's convenient to put it here. +;;;; It's not needed at cold init, so we *can* put it in this +;;;; warm-loaded file. And by putting it in this warm-loaded file, we +;;;; make it easy for it to get to the C-level 'environ' variable. +;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not +;;;; visible at GENESIS time. + +#-win32 +(progn + (define-alien-routine wrapped-environ (* c-string)) + (defun posix-environ () + "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs." + (c-strings->string-list (wrapped-environ)))) + +#+win32 +(progn + (defun decode-windows-environment (environment) + (loop until (zerop (sap-ref-8 environment 0)) + collect + (let ((string (sb-alien::c-string-to-string environment + (sb-alien::default-c-string-external-format) + 'character))) + (loop for value = (sap-ref-8 environment 0) + do (setf environment (sap+ environment 1)) + until (zerop value)) + string))) + + (defun encode-windows-environment (list) + (let* ((external-format (sb-alien::default-c-string-external-format)) + octets + (length 1)) ;; 1 for \0 at the very end + (setf octets + (loop for x in list + for octet = + (string-to-octets x :external-format external-format + :null-terminate t) + collect octet + do + (incf length (length octet)))) + (let ((mem (allocate-system-memory length)) + (index 0)) + + (loop for string in octets + for length = (length string) + do + (copy-ub8-to-system-area string 0 mem index length) + (incf index length)) + (setf (sap-ref-8 mem index) 0) + (values mem mem length)))) -(file-comment - "$Header$") + (defun posix-environ () + (decode-windows-environment + (alien-funcall (extern-alien "GetEnvironmentStrings" + (function system-area-pointer)))))) + +;;; Convert from a CMU CL representation of a Unix environment to a +;;; SBCL representation. +(defun unix-environment-sbcl-from-cmucl (cmucl) + (mapcar + (lambda (cons) + (destructuring-bind (key . val) cons + (declare (type keyword key) (string val)) + (concatenate 'simple-string (symbol-name key) "=" val))) + cmucl)) ;;;; Import wait3(2) from Unix. -(sb-alien:def-alien-routine ("wait3" c-wait3) sb-c-call:int - (status sb-c-call:int :out) - (options sb-c-call:int) - (rusage sb-c-call:int)) - -(eval-when (load eval compile) - (defconstant wait-wnohang #-svr4 1 #+svr4 #o100) - (defconstant wait-wuntraced #-svr4 2 #+svr4 4) - (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced)) +#-win32 +(define-alien-routine ("waitpid" c-waitpid) int + (pid int) + (status int :out) + (options int)) -(defun wait3 (&optional do-not-hang check-for-stopped) - "Return any available status information on child process. " +#-win32 +(defun waitpid (pid &optional do-not-hang check-for-stopped) + #+sb-doc + "Return any available status information on child process with PID." (multiple-value-bind (pid status) - (c-wait3 (logior (if do-not-hang - wait-wnohang - 0) - (if check-for-stopped - wait-wuntraced - 0)) - 0) + (c-waitpid pid + (logior (if do-not-hang + sb-unix:wnohang + 0) + (if check-for-stopped + sb-unix:wuntraced + 0))) (cond ((or (minusp pid) - (zerop pid)) - nil) - ((eql (ldb (byte 8 0) status) - wait-wstopped) - (values pid - :stopped - (ldb (byte 8 8) status))) - ((zerop (ldb (byte 7 0) status)) - (values pid - :exited - (ldb (byte 8 8) status))) - (t - (let ((signal (ldb (byte 7 0) status))) - (values pid - (if (or (eql signal sb-unix:sigstop) - (eql signal sb-unix:sigtstp) - (eql signal sb-unix:sigttin) - (eql signal sb-unix:sigttou)) - :stopped - :signaled) - signal - (not (zerop (ldb (byte 1 7) status))))))))) + (zerop pid)) + nil) + ((eql (ldb (byte 8 0) status) + sb-unix:wstopped) + (values pid + :stopped + (ldb (byte 8 8) status))) + ((zerop (ldb (byte 7 0) status)) + (values pid + :exited + (ldb (byte 8 8) status))) + (t + (let ((signal (ldb (byte 7 0) status))) + (values pid + (if (position signal + #.(vector + sb-unix:sigstop + sb-unix:sigtstp + sb-unix:sigttin + sb-unix:sigttou)) + :stopped + :signaled) + signal + (not (zerop (ldb (byte 1 7) status))))))))) ;;;; process control stuff - (defvar *active-processes* nil + #+sb-doc "List of process structures for all active processes.") -(defstruct (process) - pid ; PID of child process +(defvar *active-processes-lock* + (sb-thread:make-mutex :name "Lock for active processes.")) + +;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a +;;; mutex is needed. More importantly the sigchld signal handler also +;;; accesses it, that's why we need without-interrupts. +(defmacro with-active-processes-lock (() &body body) + `(sb-thread::with-system-mutex (*active-processes-lock*) + ,@body)) + +(defstruct (process (:copier nil)) + pid ; PID of child process %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED - exit-code ; either exit code or signal - core-dumped ; T if a core image was dumped - pty ; stream to child's pty, or NIL - input ; stream to child's input, or NIL - output ; stream from child's output, or NIL - error ; stream from child's error output, or NIL - status-hook ; closure to call when PROC changes status - plist ; a place for clients to stash things + %exit-code ; either exit code or signal + core-dumped ; T if a core image was dumped + #-win32 pty ; stream to child's pty, or NIL + input ; stream to child's input, or NIL + output ; stream from child's output, or NIL + error ; stream from child's error output, or NIL + status-hook ; closure to call when PROC changes status + plist ; a place for clients to stash things cookie) ; list of the number of pipes from the subproc (defmethod print-object ((process process) stream) (print-unreadable-object (process stream :type t) - (format stream - "~D ~S" - (process-pid process) - (process-status process))) - process) + (let ((status (process-status process))) + (if (eq :exited status) + (format stream "~S ~S" status (process-%exit-code process)) + (format stream "~S ~S" (process-pid process) status))) + process)) -(defun process-status (proc) - "Return the current status of process. The result is one of :RUNNING, +#+sb-doc +(setf (documentation 'process-p 'function) + "T if OBJECT is a PROCESS, NIL otherwise.") + +#+sb-doc +(setf (documentation 'process-pid 'function) "The pid of the child process.") + +#+win32 +(define-alien-routine ("GetExitCodeProcess" get-exit-code-process) + int + (handle unsigned) (exit-code unsigned :out)) + +(defun process-exit-code (process) + #+sb-doc + "Return the exit code of PROCESS." + (or (process-%exit-code process) + (progn (get-processes-status-changes) + (process-%exit-code process)))) + +(defun process-status (process) + #+sb-doc + "Return the current status of PROCESS. The result is one of :RUNNING, :STOPPED, :EXITED, or :SIGNALED." (get-processes-status-changes) - (process-%status proc)) + (process-%status process)) + +#+sb-doc +(setf (documentation 'process-exit-code 'function) + "The exit code or the signal of a stopped process.") + +#+sb-doc +(setf (documentation 'process-core-dumped 'function) + "T if a core image was dumped by the process.") + +#+sb-doc +(setf (documentation 'process-pty 'function) + "The pty stream of the process or NIL.") + +#+sb-doc +(setf (documentation 'process-input 'function) + "The input stream of the process or NIL.") + +#+sb-doc +(setf (documentation 'process-output 'function) + "The output stream of the process or NIL.") + +#+sb-doc +(setf (documentation 'process-error 'function) + "The error stream of the process or NIL.") + +#+sb-doc +(setf (documentation 'process-status-hook 'function) + "A function that is called when PROCESS changes its status. +The function is called with PROCESS as its only argument.") + +#+sb-doc +(setf (documentation 'process-plist 'function) + "A place for clients to stash things.") -(defun process-wait (proc &optional check-for-stopped) - "Wait for PROC to quit running for some reason. Returns PROC." +(defun process-wait (process &optional check-for-stopped) + #+sb-doc + "Wait for PROCESS to quit running for some reason. When +CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns +PROCESS." + (declare (ignorable check-for-stopped)) + #+win32 + (let ((pid (process-pid process))) + (when (and pid (plusp pid)) + (without-interrupts + (do () + ((= 0 + (with-local-interrupts + (sb-win32:wait-object-or-signal pid)))))))) + #-win32 (loop - (case (process-status proc) - (:running) - (:stopped - (when check-for-stopped - (return))) - (t - (when (zerop (car (process-cookie proc))) - (return)))) - (sb-sys:serve-all-events 1)) - proc) - -#-hpux + (case (process-status process) + (:running) + (:stopped + (when check-for-stopped + (return))) + (t + (when (zerop (car (process-cookie process))) + (return)))) + (serve-all-events 1)) + process) + +#-win32 ;;; Find the current foreground process group id. (defun find-current-foreground-process (proc) - (sb-alien:with-alien ((result sb-c-call:int)) + (with-alien ((result int)) (multiple-value-bind - (wonp error) - (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) - sb-unix:TIOCGPGRP - (sb-alien:alien-sap (sb-alien:addr result))) + (wonp error) + (sb-unix:unix-ioctl (fd-stream-fd (process-pty proc)) + sb-unix:TIOCGPGRP + (alien-sap (addr result))) (unless wonp - (error "TIOCPGRP ioctl failed: ~S" - (sb-unix:get-unix-error-msg error))) + (error "TIOCPGRP ioctl failed: ~S" (strerror error))) result)) (process-pid proc)) -(defun process-kill (proc signal &optional (whom :pid)) - "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If - whom is :process-group, use the killpg Unix system call. If whom is - :pty-process-group deliver the signal to whichever process group is currently - in the foreground." +#-win32 +(defun process-kill (process signal &optional (whom :pid)) + #+sb-doc + "Hand SIGNAL to PROCESS. If WHOM is :PID, use the kill Unix system call. If + WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is + :PTY-PROCESS-GROUP deliver the signal to whichever process group is + currently in the foreground." (let ((pid (ecase whom - ((:pid :process-group) - (process-pid proc)) - (:pty-process-group - #-hpux - (find-current-foreground-process proc))))) + ((:pid :process-group) + (process-pid process)) + (:pty-process-group + (find-current-foreground-process process))))) (multiple-value-bind - (okay errno) - (case whom - #+hpux - (:pty-process-group - (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) - sb-unix:TIOCSIGSEND - (sb-sys:int-sap - (sb-unix:unix-signal-number signal)))) - ((:process-group #-hpux :pty-process-group) - (sb-unix:unix-killpg pid signal)) - (t - (sb-unix:unix-kill pid signal))) + (okay errno) + (case whom + ((:process-group) + (sb-unix:unix-killpg pid signal)) + (t + (sb-unix:unix-kill pid signal))) (cond ((not okay) - (values nil errno)) - ((and (eql pid (process-pid proc)) - (= (sb-unix:unix-signal-number signal) sb-unix:sigcont)) - (setf (process-%status proc) :running) - (setf (process-exit-code proc) nil) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - t) - (t - t))))) - -(defun process-alive-p (proc) - "Return T if the process is still alive, NIL otherwise." - (let ((status (process-status proc))) + (values nil errno)) + ((and (eql pid (process-pid process)) + (= signal sb-unix:sigcont)) + (setf (process-%status process) :running) + (setf (process-%exit-code process) nil) + (when (process-status-hook process) + (funcall (process-status-hook process) process)) + t) + (t + t))))) + +(defun process-alive-p (process) + #+sb-doc + "Return T if PROCESS is still alive, NIL otherwise." + (let ((status (process-status process))) (if (or (eq status :running) - (eq status :stopped)) - t - nil))) + (eq status :stopped)) + t + nil))) -(defun process-close (proc) - "Close all streams connected to PROC and stop maintaining the status slot." +(defun process-close (process) + #+sb-doc + "Close all streams connected to PROCESS and stop maintaining the +status slot." (macrolet ((frob (stream abort) - `(when ,stream (close ,stream :abort ,abort)))) - (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, .. - (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE. - (frob (process-output proc) nil) - (frob (process-error proc) nil)) - (sb-sys:without-interrupts - (setf *active-processes* (delete proc *active-processes*))) - proc) - -;;; the handler for sigchld signals that RUN-PROGRAM establishes -(defun sigchld-handler (ignore1 ignore2 ignore3) - (declare (ignore ignore1 ignore2 ignore3)) - (get-processes-status-changes)) + `(when ,stream (close ,stream :abort ,abort)))) + #-win32 + (frob (process-pty process) t) ; Don't FLUSH-OUTPUT to dead process, + (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE. + (frob (process-output process) nil) + (frob (process-error process) nil)) + ;; FIXME: Given that the status-slot is no longer updated, + ;; maybe it should be set to :CLOSED, or similar? + (with-active-processes-lock () + (setf *active-processes* (delete process *active-processes*))) + #+win32 + (let ((handle (shiftf (process-pid process) nil))) + (when (and handle (plusp handle)) + (or (sb-win32:close-handle handle) + (sb-win32::win32-error 'process-close)))) + process) (defun get-processes-status-changes () - (loop - (multiple-value-bind (pid what code core) - (wait3 t t) - (unless pid - (return)) - (let ((proc (find pid *active-processes* :key #'process-pid))) - (when proc - (setf (process-%status proc) what) - (setf (process-exit-code proc) code) - (setf (process-core-dumped proc) core) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - (when (or (eq what :exited) - (eq what :signaled)) - (sb-sys:without-interrupts - (setf *active-processes* - (delete proc *active-processes*))))))))) + (let (exited) + (with-active-processes-lock () + (setf *active-processes* + (delete-if #-win32 + (lambda (proc) + ;; Wait only on pids belonging to processes + ;; started by RUN-PROGRAM. There used to be a + ;; WAIT3 call here, but that makes direct + ;; WAIT, WAITPID usage impossible due to the + ;; race with the SIGCHLD signal handler. + (multiple-value-bind (pid what code core) + (waitpid (process-pid proc) t t) + (when pid + (setf (process-%status proc) what) + (setf (process-%exit-code proc) code) + (setf (process-core-dumped proc) core) + (when (process-status-hook proc) + (push proc exited)) + t))) + #+win32 + (lambda (proc) + (let ((pid (process-pid proc))) + (when pid + (multiple-value-bind (ok code) + (sb-win32::get-exit-code-process pid) + (when (and (plusp ok) (/= code 259)) + (setf (process-%status proc) :exited + (process-%exit-code proc) code) + (when (process-status-hook proc) + (push proc exited)) + t))))) + *active-processes*))) + ;; Can't call the hooks before all the processes have been deal + ;; with, as calling a hook may cause re-entry to + ;; GET-PROCESS-STATUS-CHANGES. That may be OK when using waitpid, + ;; but in the Windows implementation it would be deeply bad. + (dolist (proc exited) + (let ((hook (process-status-hook proc))) + (when hook + (funcall hook proc)))))) ;;;; RUN-PROGRAM and close friends -(defvar *close-on-error* nil - "List of file descriptors to close when RUN-PROGRAM exits due to an error.") -(defvar *close-in-parent* nil - "List of file descriptors to close when RUN-PROGRAM returns in the parent.") -(defvar *handlers-installed* nil - "List of handlers installed by RUN-PROGRAM.") - -#+FreeBSD -(def-alien-type nil - (struct sgttyb - (sg-ispeed sb-c-call:char) ; input speed - (sg-ospeed sb-c-call:char) ; output speed - (sg-erase sb-c-call:char) ; erase character - (sg-kill sb-c-call:char) ; kill character - (sg-flags sb-c-call:short) ; mode flags - )) - -;;; Find a pty that is not in use. Return three values: the file -;;; descriptor for the master side of the pty, the file descriptor for -;;; the slave side of the pty, and the name of the tty device for the -;;; slave side. -(defun find-a-pty () - (dolist (char '(#\p #\q)) - (dotimes (digit 16) - (let* ((master-name (format nil "/dev/pty~C~X" char digit)) - (master-fd (sb-unix:unix-open master-name - sb-unix:o_rdwr - #o666))) - (when master-fd - (let* ((slave-name (format nil "/dev/tty~C~X" char digit)) - (slave-fd (sb-unix:unix-open slave-name - sb-unix:o_rdwr - #o666))) - (when slave-fd - ; Maybe put a vhangup here? - #-linux - (sb-alien:with-alien ((stuff (sb-alien:struct sgttyb))) - (let ((sap (sb-alien:alien-sap stuff))) - (sb-unix:unix-ioctl slave-fd sb-unix:TIOCGETP sap) - (setf (sb-alien:slot stuff 'sg-flags) - #o300) ; EVENP|ODDP - (sb-unix:unix-ioctl slave-fd sb-unix:TIOCSETP sap) - (sb-unix:unix-ioctl master-fd sb-unix:TIOCGETP sap) - (setf (sb-alien:slot stuff 'sg-flags) - (logand (sb-alien:slot stuff 'sg-flags) - (lognot 8))) ; ~ECHO - (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap))) - (return-from find-a-pty - (values master-fd - slave-fd - slave-name))) - (sb-unix:unix-close master-fd)))))) - (error "could not find a pty")) - -(defun open-pty (pty cookie) +;;; list of file descriptors to close when RUN-PROGRAM exits due to an error +(defvar *close-on-error* nil) + +;;; list of file descriptors to close when RUN-PROGRAM returns in the parent +(defvar *close-in-parent* nil) + +;;; list of handlers installed by RUN-PROGRAM. FIXME: nothing seems +;;; to set this. +#-win32 +(defvar *handlers-installed* nil) + +;;; Find an unused pty. Return three values: the file descriptor for +;;; the master side of the pty, the file descriptor for the slave side +;;; of the pty, and the name of the tty device for the slave side. +#-(or win32 openbsd) +(progn + (define-alien-routine ptsname c-string (fd int)) + (define-alien-routine grantpt boolean (fd int)) + (define-alien-routine unlockpt boolean (fd int)) + + (defun find-a-pty () + ;; First try to use the Unix98 pty api. + (let* ((master-name (coerce (format nil "/dev/ptmx") 'base-string)) + (master-fd (sb-unix:unix-open master-name + (logior sb-unix:o_rdwr + sb-unix:o_noctty) + #o666))) + (when master-fd + (grantpt master-fd) + (unlockpt master-fd) + (let* ((slave-name (ptsname master-fd)) + (slave-fd (sb-unix:unix-open slave-name + (logior sb-unix:o_rdwr + sb-unix:o_noctty) + #o666))) + (when slave-fd + (return-from find-a-pty + (values master-fd + slave-fd + slave-name))) + (sb-unix:unix-close master-fd)) + (error "could not find a pty"))) + ;; No dice, try using the old-school method. + (dolist (char '(#\p #\q)) + (dotimes (digit 16) + (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) + 'base-string)) + (master-fd (sb-unix:unix-open master-name + (logior sb-unix:o_rdwr + sb-unix:o_noctty) + #o666))) + (when master-fd + (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) + 'base-string)) + (slave-fd (sb-unix:unix-open slave-name + (logior sb-unix:o_rdwr + sb-unix:o_noctty) + #o666))) + (when slave-fd + (return-from find-a-pty + (values master-fd + slave-fd + slave-name))) + (sb-unix:unix-close master-fd)))))) + (error "could not find a pty"))) +#+openbsd +(progn + (define-alien-routine openpty int (amaster int :out) (aslave int :out) + (name (* char)) (termp (* t)) (winp (* t))) + (defun find-a-pty () + (with-alien ((name-buf (array char 16))) + (multiple-value-bind (return-val master-fd slave-fd) + (openpty (cast name-buf (* char)) nil nil) + (if (zerop return-val) + (values master-fd + slave-fd + (sb-alien::c-string-to-string (alien-sap name-buf) + (sb-impl::default-external-format) + 'character)) + (error "could not find a pty")))))) + +#-win32 +(defun open-pty (pty cookie &key (external-format :default)) (when pty (multiple-value-bind - (master slave name) - (find-a-pty) + (master slave name) + (find-a-pty) (push master *close-on-error*) (push slave *close-in-parent*) (when (streamp pty) - (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master) - (unless new-fd - (error "could not SB-UNIX:UNIX-DUP ~D: ~S" - master (sb-unix:get-unix-error-msg errno))) - (push new-fd *close-on-error*) - (copy-descriptor-to-stream new-fd pty cookie))) + (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master) + (unless new-fd + (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno))) + (push new-fd *close-on-error*) + (copy-descriptor-to-stream new-fd pty cookie external-format))) (values name - (sb-sys:make-fd-stream master :input t :output t))))) + (make-fd-stream master :input t :output t + :external-format external-format + :element-type :default + :dual-channel-p t))))) -(defmacro round-bytes-to-words (n) - `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) +;; Null terminate strings only C-side: otherwise we can run into +;; A-T-S-L even for simple encodings like ASCII. Multibyte encodings +;; may need more than a single byte of zeros; assume 4 byte is enough +;; for everyone. +#-win32 +(defmacro round-null-terminated-bytes-to-words (n) + `(logandc2 (the sb-vm:signed-word (+ (the fixnum ,n) + 4 (1- sb-vm:n-word-bytes))) + (1- sb-vm:n-word-bytes))) +#-win32 (defun string-list-to-c-strvec (string-list) - ;; Make a pass over STRING-LIST to calculate the amount of memory - ;; needed to hold the strvec. - (let ((string-bytes 0) - ;; We need an extra for the null, and an extra 'cause exect - ;; clobbers argv[-1]. - (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2)))) - (declare (fixnum string-bytes vec-bytes)) - (dolist (s string-list) - (check-type s simple-string) - (incf string-bytes (round-bytes-to-words (1+ (length s))))) - ;; Now allocate the memory and fill it in. - (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (sb-sys:allocate-system-memory total-bytes)) - (string-sap (sap+ vec-sap vec-bytes)) - (i #-alpha 4 #+alpha 8)) - (declare (type (and unsigned-byte fixnum) total-bytes i) - (type sb-sys:system-area-pointer vec-sap string-sap)) - (dolist (s string-list) - (declare (simple-string s)) - (let ((n (length s))) - ;; Blast the string into place. - (sb-kernel:copy-to-system-area (the simple-string s) - (* sb-vm:vector-data-offset - sb-vm:word-bits) - string-sap 0 - (* (1+ n) sb-vm:byte-bits)) - ;; Blast the pointer to the string into place. - (setf (sap-ref-sap vec-sap i) string-sap) - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i #-alpha 4 #+alpha 8))) - ;; Blast in the last null pointer. - (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes)))) - -(defmacro with-c-strvec ((var str-list) &body body) - (let ((sap (gensym "SAP-")) - (size (gensym "SIZE-"))) - `(multiple-value-bind - (,sap ,var ,size) - (string-list-to-c-strvec ,str-list) - (unwind-protect - (progn - ,@body) - (sb-sys:deallocate-system-memory ,sap ,size))))) - -(sb-alien:def-alien-routine spawn sb-c-call:int - (program sb-c-call:c-string) - (argv (* sb-c-call:c-string)) - (envp (* sb-c-call:c-string)) - (pty-name sb-c-call:c-string) - (stdin sb-c-call:int) - (stdout sb-c-call:int) - (stderr sb-c-call:int)) - -;;; RUN-PROGRAM uses fork and execve to run a different program. -;;; Strange stuff happens to keep the unix state of the world + (let* (;; We need an extra for the null, and an extra 'cause exect + ;; clobbers argv[-1]. + (vec-bytes (* sb-vm:n-word-bytes (+ (length string-list) 2))) + (octet-vector-list (mapcar (lambda (s) + (string-to-octets s)) + string-list)) + (string-bytes (reduce #'+ octet-vector-list + :key (lambda (s) + (round-null-terminated-bytes-to-words + (length s))))) + (total-bytes (+ string-bytes vec-bytes)) + ;; Memory to hold the vector of pointers and all the strings. + (vec-sap (allocate-system-memory total-bytes)) + (string-sap (sap+ vec-sap vec-bytes)) + ;; Index starts from [1]! + (vec-index-offset sb-vm:n-word-bytes)) + (declare (sb-vm:signed-word vec-bytes) + (sb-vm:word string-bytes total-bytes) + (system-area-pointer vec-sap string-sap)) + (dolist (octets octet-vector-list) + (declare (type (simple-array (unsigned-byte 8) (*)) octets)) + (let ((size (length octets))) + ;; Copy string. + (sb-kernel:copy-ub8-to-system-area octets 0 string-sap 0 size) + ;; NULL-terminate it + (sb-kernel:system-area-ub8-fill 0 string-sap size 4) + ;; Put the pointer in the vector. + (setf (sap-ref-sap vec-sap vec-index-offset) string-sap) + ;; Advance string-sap for the next string. + (setf string-sap (sap+ string-sap + (round-null-terminated-bytes-to-words size))) + (incf vec-index-offset sb-vm:n-word-bytes))) + ;; Final null pointer. + (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0)) + (values vec-sap (sap+ vec-sap sb-vm:n-word-bytes) total-bytes))) + +#-win32 +(defmacro with-args ((var str-list) &body body) + (with-unique-names (sap size) + `(multiple-value-bind (,sap ,var ,size) + (string-list-to-c-strvec ,str-list) + (unwind-protect + (progn + ,@body) + (deallocate-system-memory ,sap ,size))))) + +(defmacro with-environment ((var str-list &key null) &body body) + (once-only ((null null)) + (with-unique-names (sap size) + `(multiple-value-bind (,sap ,var ,size) + (if ,null + (values nil (int-sap 0)) + #-win32 (string-list-to-c-strvec ,str-list) + #+win32 (encode-windows-environment ,str-list)) + (unwind-protect + (progn + ,@body) + (unless ,null + (deallocate-system-memory ,sap ,size))))))) +#-win32 +(define-alien-routine spawn + int + (program c-string) + (argv (* c-string)) + (stdin int) + (stdout int) + (stderr int) + (search int) + (envp (* c-string)) + (pty-name c-string) + (wait int) + (dir c-string)) + +#+win32 +(defun escape-arg (arg stream) + ;; Normally, #\\ doesn't have to be escaped + ;; But if #\" follows #\\, then they have to be escaped. + ;; Do that by counting the number of consequent backslashes, and + ;; upon encoutering #\" immediately after them, output the same + ;; number of backslashes, plus one for #\" + (write-char #\" stream) + (loop with slashes = 0 + for i below (length arg) + for previous-char = #\a then char + for char = (char arg i) + do + (case char + (#\" + (loop repeat slashes + do (write-char #\\ stream)) + (write-string "\\\"" stream)) + (t + (write-char char stream))) + (case char + (#\\ + (incf slashes)) + (t + (setf slashes 0))) + finally + ;; The final #\" counts too, but doesn't need to be escaped itself + (loop repeat slashes + do (write-char #\\ stream))) + (write-char #\" stream)) + +(defun prepare-args (args) + (cond #-win32 + ((every #'simple-string-p args) + args) + #-win32 + (t + (loop for arg in args + collect (coerce arg 'simple-string))) + #+win32 + (t + (with-output-to-string (str) + (loop for (arg . rest) on args + do + (cond ((find-if (lambda (c) (find c '(#\Space #\Tab #\"))) + arg) + (escape-arg arg str)) + (t + (princ arg str))) + (when rest + (write-char #\Space str))))))) + +;;; FIXME: There shouldn't be two semiredundant versions of the +;;; documentation. Since this is a public extension function, the +;;; documentation should be in the doc string. So all information from +;;; this comment should be merged into the doc string, and then this +;;; comment can go away. +;;; +;;; RUN-PROGRAM uses fork() and execve() to run a different program. +;;; Strange stuff happens to keep the Unix state of the world ;;; coherent. ;;; -;;; The child process needs to get it's input from somewhere, and send +;;; The child process needs to get its input from somewhere, and send ;;; its output (both standard and error) to somewhere. We have to do ;;; different things depending on where these somewheres really are. ;;; @@ -345,16 +647,16 @@ ;;; -- T: Just leave fd 0 alone. Pretty simple. ;;; -- "file": Read from the file. We need to open the file and ;;; pull the descriptor out of the stream. The parent should close -;;; this stream after the child is up and running to free any +;;; this stream after the child is up and running to free any ;;; storage used in the parent. ;;; -- NIL: Same as "file", but use "/dev/null" as the file. -;;; -- :STREAM: Use unix-pipe to create two descriptors. Use -;;; sb-sys:make-fd-stream to create the output stream on the +;;; -- :STREAM: Use Unix pipe() to create two descriptors. Use +;;; SB-SYS:MAKE-FD-STREAM to create the output stream on the ;;; writeable descriptor, and pass the readable descriptor to ;;; the child. The parent must close the readable descriptor for ;;; EOF to be passed up correctly. ;;; -- a stream: If it's a fd-stream, just pull the descriptor out -;;; of it. Otherwise make a pipe as in :STREAM, and copy +;;; of it. Otherwise make a pipe as in :STREAM, and copy ;;; everything across. ;;; ;;; For output, there are five options: @@ -371,294 +673,543 @@ ;;; RUN-PROGRAM returns a PROCESS structure for the process if ;;; the fork worked, and NIL if it did not. (defun run-program (program args - &key env (wait t) pty input - if-input-does-not-exist output (if-output-exists :error) - (error :output) (if-error-exists :error) status-hook) - "RUN-PROGRAM creates a new process and runs the unix progam in the - file specified by the simple-string program. Args are the standard - arguments that can be passed to a Unix program, for no arguments - use NIL (which means just the name of the program is passed as arg 0). - - RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU - Common Lisp Users Manual for details about the PROCESS structure. - - The keyword arguments have the following meanings: - :env - - An A-LIST mapping keyword environment variables to simple-string - values. - :wait - - If non-NIL (default), wait until the created process finishes. If - NIL, continue running Lisp until the program finishes. - :pty - - Either T, NIL, or a stream. Unless NIL, the subprocess is established - under a PTY. If :pty is a stream, all output to this pty is sent to - this stream, otherwise the PROCESS-PTY slot is filled in with a stream - connected to pty that can read output and write input. - :input - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - input for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the input is read from that stream and send to the subprocess. If - :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends - its output to the process. Defaults to NIL. - :if-input-does-not-exist (when :input is the name of a file) - - can be one of: - :error - generate an error. - :create - create an empty file. - nil (default) - return nil from run-program. - :output - - Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - output for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the output from the process is written to this stream. If - :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can - be read to get the output. Defaults to NIL. - :if-output-exists (when :input is the name of a file) - - can be one of: - :error (default) - generates an error if the file already exists. - :supersede - output from the program supersedes the file. - :append - output from the program is appended to the file. - nil - run-program returns nil without doing anything. - :error and :if-error-exists - - Same as :output and :if-output-exists, except that :error can also be - specified as :output in which case all error output is routed to the - same place as normal output. - :status-hook - - This is a function the system calls whenever the status of the - process changes. The function takes the process as an argument." - - ;; Make sure the interrupt handler is installed. - (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler) - ;; Make sure all the args are okay. - (unless (every #'simple-string-p args) - (error "All arguments to program must be simple strings: ~S" args)) - ;; Pre-pend the program to the argument list. - (push (namestring program) args) - ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate - ;; cleanup info. Also, establish proc at this level so we can - ;; return it. - (let (*close-on-error* *close-in-parent* *handlers-installed* proc) + &key + (env nil env-p) + (environment + (when env-p + (unix-environment-sbcl-from-cmucl env)) + environment-p) + (wait t) + search + #-win32 pty + input + if-input-does-not-exist + output + (if-output-exists :error) + (error :output) + (if-error-exists :error) + status-hook + (external-format :default) + (directory nil directory-p)) + #+sb-doc + #.(concatenate + 'string + ;; The Texinfoizer is sensitive to whitespace, so mind the + ;; placement of the #-win32 pseudosplicings. + "RUN-PROGRAM creates a new process specified by the PROGRAM +argument. ARGS are the standard arguments that can be passed to a +program. For no arguments, use NIL (which means that just the +name of the program is passed as arg 0). + +The program arguments and the environment are encoded using the +default external format for streams. + +RUN-PROGRAM will return a PROCESS structure. See the CMU Common Lisp +Users Manual for details about the PROCESS structure. + + Notes about Unix environments (as in the :ENVIRONMENT and :ENV args): + + - The SBCL implementation of RUN-PROGRAM, like Perl and many other + programs, but unlike the original CMU CL implementation, copies + the Unix environment by default."#-win32" + - Running Unix programs from a setuid process, or in any other + situation where the Unix environment is under the control of someone + else, is a mother lode of security problems. If you are contemplating + doing this, read about it first. (The Perl community has a lot of good + documentation about this and other security issues in script-like + programs.)"" + + The &KEY arguments have the following meanings: + :ENVIRONMENT + a list of STRINGs describing the new Unix environment + (as in \"man environ\"). The default is to copy the environment of + the current process. + :ENV + an alternative lossy representation of the new Unix environment, + for compatibility with CMU CL + :SEARCH + Look for PROGRAM in each of the directories in the child's $PATH + environment variable. Otherwise an absolute pathname is required. + :WAIT + If non-NIL (default), wait until the created process finishes. If + NIL, continue running Lisp until the program finishes."#-win32" + :PTY + Either T, NIL, or a stream. Unless NIL, the subprocess is established + under a PTY. If :pty is a stream, all output to this pty is sent to + this stream, otherwise the PROCESS-PTY slot is filled in with a stream + connected to pty that can read output and write input."" + :INPUT + Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard + input for the current process is inherited. If NIL, " + #-win32"/dev/null"#+win32"nul"" + is used. If a pathname, the file so specified is used. If a stream, + all the input is read from that stream and sent to the subprocess. If + :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends + its output to the process. Defaults to NIL. + :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file) + can be one of: + :ERROR to generate an error + :CREATE to create an empty file + NIL (the default) to return NIL from RUN-PROGRAM + :OUTPUT + Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard + output for the current process is inherited. If NIL, " + #-win32"/dev/null"#+win32"nul"" + is used. If a pathname, the file so specified is used. If a stream, + all the output from the process is written to this stream. If + :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can + be read to get the output. Defaults to NIL. + :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file) + can be one of: + :ERROR (the default) to generate an error + :SUPERSEDE to supersede the file with output from the program + :APPEND to append output from the program to the file + NIL to return NIL from RUN-PROGRAM, without doing anything + :ERROR and :IF-ERROR-EXISTS + Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be + specified as :OUTPUT in which case all error output is routed to the + same place as normal output. + :STATUS-HOOK + This is a function the system calls whenever the status of the + process changes. The function takes the process as an argument. + :EXTERNAL-FORMAT + The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs. + :DIRECTORY + Specifies the directory in which the program should be run. + NIL (the default) means the directory is unchanged.") + (when (and env-p environment-p) + (error "can't specify :ENV and :ENVIRONMENT simultaneously")) + (let* (;; Clear various specials used by GET-DESCRIPTOR-FOR to + ;; communicate cleanup info. + *close-on-error* + *close-in-parent* + ;; Some other binding used only on non-Win32. FIXME: + ;; nothing seems to set this. + #-win32 *handlers-installed* + ;; Establish PROC at this level so that we can return it. + proc + (progname (native-namestring program)) + (args (prepare-args (cons progname args))) + (directory (and directory-p (native-namestring directory))) + ;; Gag. + (cookie (list 0))) (unwind-protect - (let ((pfile (unix-namestring (merge-pathnames program "path:") t t)) - (cookie (list 0))) - (unless pfile - (error "no such program: ~S" program)) - (multiple-value-bind - (stdin input-stream) - (get-descriptor-for input cookie :direction :input - :if-does-not-exist if-input-does-not-exist) - (multiple-value-bind - (stdout output-stream) - (get-descriptor-for output cookie :direction :output - :if-exists if-output-exists) - (multiple-value-bind - (stderr error-stream) - (if (eq error :output) - (values stdout output-stream) - (get-descriptor-for error cookie :direction :output - :if-exists if-error-exists)) - (multiple-value-bind (pty-name pty-stream) - (open-pty pty cookie) - ;; Make sure we are not notified about the child - ;; death before we have installed the PROCESS - ;; structure in *ACTIVE-PROCESSES*. - (sb-sys:without-interrupts - (with-c-strvec (argv args) - (with-c-strvec - (envp (mapcar #'(lambda (entry) - (concatenate - 'string - (symbol-name (car entry)) - "=" - (cdr entry))) - env)) - (let ((child-pid - (without-gcing - (spawn pfile argv envp pty-name - stdin stdout stderr)))) - (when (< child-pid 0) - (error "could not fork child process: ~S" - (sb-unix:get-unix-error-msg))) - (setf proc (make-process :pid child-pid - :%status :running - :pty pty-stream - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie)) - (push proc *active-processes*)))))))))) + ;; Note: despite the WITH-* names, these macros don't + ;; expand into UNWIND-PROTECT forms. They're just + ;; syntactic sugar to make the rest of the routine slightly + ;; easier to read. + (macrolet ((with-fd-and-stream-for (((fd stream) which &rest args) + &body body) + `(multiple-value-bind (,fd ,stream) + ,(ecase which + ((:input :output) + `(get-descriptor-for ,@args)) + (:error + `(if (eq ,(first args) :output) + ;; kludge: we expand into + ;; hard-coded symbols here. + (values stdout output-stream) + (get-descriptor-for ,@args)))) + (unless ,fd + (return-from run-program)) + ,@body)) + (with-open-pty (((pty-name pty-stream) (pty cookie)) + &body body) + (declare (ignorable pty-name pty-stream pty cookie)) + #+win32 + `(progn ,@body) + #-win32 + `(multiple-value-bind (,pty-name ,pty-stream) + (open-pty ,pty ,cookie :external-format external-format) + ,@body))) + (with-fd-and-stream-for ((stdin input-stream) :input + input cookie + :direction :input + :if-does-not-exist if-input-does-not-exist + :external-format external-format + :wait wait) + (with-fd-and-stream-for ((stdout output-stream) :output + output cookie + :direction :output + :if-exists if-output-exists + :external-format external-format) + (with-fd-and-stream-for ((stderr error-stream) :error + error cookie + :direction :output + :if-exists if-error-exists + :external-format external-format) + (with-open-pty ((pty-name pty-stream) (pty cookie)) + ;; Make sure we are not notified about the child + ;; death before we have installed the PROCESS + ;; structure in *ACTIVE-PROCESSES*. + (let (child) + (with-active-processes-lock () + (with-environment (environment-vec environment + :null (not (or environment environment-p))) + (setq child + #+win32 + (sb-win32::mswin-spawn + progname + args + stdin stdout stderr + search environment-vec wait directory) + #-win32 + (with-args (args-vec args) + (without-gcing + (spawn progname args-vec + stdin stdout stderr + (if search 1 0) + environment-vec pty-name + (if wait 1 0) directory)))) + (unless (minusp child) + (setf proc + (make-process + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie + #-win32 :pty #-win32 pty-stream + :%status #-win32 :running + #+win32 (if wait + :exited + :running) + :pid #-win32 child + #+win32 (if wait + nil + child) + #+win32 :%exit-code #+win32 (and wait child))) + (push proc *active-processes*)))) + ;; Report the error outside the lock. + (case child + (-1 + (error "Couldn't fork child process: ~A" + (strerror))) + (-2 + (error "Couldn't execute ~S: ~A" + progname (strerror))) + (-3 + (error "Couldn't change directory to ~S: ~A" + directory (strerror)))))))))) (dolist (fd *close-in-parent*) - (sb-unix:unix-close fd)) + (sb-unix:unix-close fd)) (unless proc - (dolist (fd *close-on-error*) - (sb-unix:unix-close fd)) - (dolist (handler *handlers-installed*) - (sb-sys:remove-fd-handler handler)))) - (when (and wait proc) - (process-wait proc)) + (dolist (fd *close-on-error*) + (sb-unix:unix-close fd)) + #-win32 + (dolist (handler *handlers-installed*) + (remove-fd-handler handler))) + #-win32 + (when (and wait proc) + (unwind-protect + (process-wait proc) + (dolist (handler *handlers-installed*) + (remove-fd-handler handler))))) proc)) -;;; COPY-DESCRIPTOR-TO-STREAM -- internal -;;; -;;; Installs a handler for any input that shows up on the file descriptor. -;;; The handler reads the data and writes it to the stream. -;;; -(defun copy-descriptor-to-stream (descriptor stream cookie) +;;; Install a handler for any input that shows up on the file +;;; descriptor. The handler reads the data and writes it to the +;;; stream. +(defun copy-descriptor-to-stream (descriptor stream cookie external-format) (incf (car cookie)) - (let ((string (make-string 256)) - handler) + (let* ((handler nil) + (buf (make-array 256 :element-type '(unsigned-byte 8))) + (read-end 0) + (et (stream-element-type stream)) + (copy-fun + (cond + ((member et '(character base-char)) + (lambda () + (let* ((decode-end read-end) + (string (handler-case + (octets-to-string + buf :end read-end + :external-format external-format) + (end-of-input-in-character (e) + (setf decode-end + (octet-decoding-error-start e)) + (octets-to-string + buf :end decode-end + :external-format external-format))))) + (unless (zerop (length string)) + (write-string string stream) + (when (/= decode-end (length buf)) + (replace buf buf :start2 decode-end :end2 read-end)) + (decf read-end decode-end))))) + ((member et '(:default (unsigned-byte 8)) :test #'equal) + (lambda () + (write-sequence buf stream :end read-end) + (setf read-end 0))) + (t + ;; FIXME. + (error "Don't know how to copy to stream of element-type ~S" + et))))) (setf handler - (sb-sys:add-fd-handler - descriptor - :input #'(lambda (fd) - (declare (ignore fd)) - (loop - (unless handler - (return)) - (multiple-value-bind - (result readable/errno) - (sb-unix:unix-select (1+ descriptor) - (ash 1 descriptor) - 0 0 0) - (cond ((null result) - (error "could not select on sub-process: ~S" - (sb-unix:get-unix-error-msg - readable/errno))) - ((zerop result) - (return)))) - (sb-alien:with-alien ((buf (sb-alien:array - sb-c-call:char - 256))) - (multiple-value-bind - (count errno) - (sb-unix:unix-read descriptor - (alien-sap buf) - 256) - (cond ((or (and (null count) - (eql errno sb-unix:eio)) - (eql count 0)) - (sb-sys:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (sb-unix:unix-close descriptor) - (return)) - ((null count) - (sb-sys:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (error "could not read input from sub-process: ~S" - (sb-unix:get-unix-error-msg errno))) - (t - (sb-kernel:copy-from-system-area - (alien-sap buf) 0 - string (* sb-vm:vector-data-offset - sb-vm:word-bits) - (* count sb-vm:byte-bits)) - (write-string string stream - :end count))))))))))) + (add-fd-handler + descriptor + :input + (lambda (fd) + (declare (ignore fd)) + (loop + (unless handler + (return)) + (multiple-value-bind + (result readable/errno) + (sb-unix:unix-select (1+ descriptor) + (ash 1 descriptor) + 0 0 0) + (cond ((null result) + (if (eql sb-unix:eintr readable/errno) + (return) + (error "~@" + (strerror readable/errno)))) + ((zerop result) + (return)))) + (multiple-value-bind (count errno) + (with-pinned-objects (buf) + (sb-unix:unix-read descriptor + (sap+ (vector-sap buf) read-end) + (- (length buf) read-end))) + (cond + ((and #-win32 (or (and (null count) + (eql errno sb-unix:eio)) + (eql count 0)) + #+win32 (<= count 0)) + (remove-fd-handler handler) + (setf handler nil) + (decf (car cookie)) + (sb-unix:unix-close descriptor) + (unless (zerop read-end) + ;; Should this be an END-OF-FILE? + (error "~@" buf)) + (return)) + ((null count) + (remove-fd-handler handler) + (setf handler nil) + (decf (car cookie)) + (error + "~@" + (strerror errno))) + (t + (incf read-end count) + (funcall copy-fun)))))))) + #-win32 + (push handler *handlers-installed*))) +;;; FIXME: something very like this is done in SB-POSIX to treat +;;; streams as file descriptor designators; maybe we can combine these +;;; two? Additionally, as we have a couple of user-defined streams +;;; libraries, maybe we should have a generic function for doing this, +;;; so user-defined streams can play nicely with RUN-PROGRAM (and +;;; maybe also with SB-POSIX)? +(defun get-stream-fd-and-external-format (stream direction) + (typecase stream + (fd-stream + (values (fd-stream-fd stream) nil (stream-external-format stream))) + (synonym-stream + (get-stream-fd-and-external-format + (symbol-value (synonym-stream-symbol stream)) direction)) + (two-way-stream + (ecase direction + (:input + (get-stream-fd-and-external-format + (two-way-stream-input-stream stream) direction)) + (:output + (get-stream-fd-and-external-format + (two-way-stream-output-stream stream) direction)))))) + +(defun get-temporary-directory () + #-win32 (or (sb-ext:posix-getenv "TMPDIR") + "/tmp") + #+win32 (or (sb-ext:posix-getenv "TEMP") + "C:/Temp")) + + ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created ;;; stream as the second value. (defun get-descriptor-for (object - cookie - &rest keys - &key direction - &allow-other-keys) - (cond ((eq object t) - ;; No new descriptor is needed. - (values -1 nil)) - ((eq object nil) - ;; Use /dev/null. - (multiple-value-bind - (fd errno) - (sb-unix:unix-open "/dev/null" - (case direction - (:input sb-unix:o_rdonly) - (:output sb-unix:o_wronly) - (t sb-unix:o_rdwr)) - #o666) - (unless fd - (error "could not open \"/dev/null\": ~S" - (sb-unix:get-unix-error-msg errno))) - (push fd *close-in-parent*) - (values fd nil))) - ((eq object :stream) - (multiple-value-bind - (read-fd write-fd) - (sb-unix:unix-pipe) - (unless read-fd - (error "could not create pipe: ~S" - (sb-unix:get-unix-error-msg write-fd))) - (case direction - (:input - (push read-fd *close-in-parent*) - (push write-fd *close-on-error*) - (let ((stream (sb-sys:make-fd-stream write-fd :output t))) - (values read-fd stream))) - (:output - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (let ((stream (sb-sys:make-fd-stream read-fd :input t))) - (values write-fd stream))) - (t - (sb-unix:unix-close read-fd) - (sb-unix:unix-close write-fd) - (error "Direction must be either :INPUT or :OUTPUT, not ~S." - direction))))) - ((or (pathnamep object) (stringp object)) - (with-open-stream (file (apply #'open object keys)) - (multiple-value-bind - (fd errno) - (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) - (cond (fd - (push fd *close-in-parent*) - (values fd nil)) - (t - (error "could not duplicate file descriptor: ~S" - (sb-unix:get-unix-error-msg errno))))))) - ((sb-sys:fd-stream-p object) - (values (sb-sys:fd-stream-fd object) nil)) - ((streamp object) - (ecase direction - (:input - ;; FIXME: We could use a better way of setting up - ;; temporary files, both here and in LOAD-FOREIGN. - (dotimes (count - 256 - (error "could not open a temporary file in /tmp")) - (let* ((name (format nil "/tmp/.run-program-~D" count)) - (fd (sb-unix:unix-open name - (logior sb-unix:o_rdwr - sb-unix:o_creat - sb-unix:o_excl) - #o666))) - (sb-unix:unix-unlink name) - (when fd - (let ((newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (sb-unix:unix-write fd line 0 (length line)) - (if no-cr - (return) - (sb-unix:unix-write fd newline 0 1))))) - (sb-unix:unix-lseek fd 0 sb-unix:l_set) - (push fd *close-in-parent*) - (return (values fd nil)))))) - (:output - (multiple-value-bind (read-fd write-fd) - (sb-unix:unix-pipe) - (unless read-fd - (error "could not create pipe: ~S" - (sb-unix:get-unix-error-msg write-fd))) - (copy-descriptor-to-stream read-fd object cookie) - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (values write-fd nil))))) - (t - (error "invalid option to RUN-PROGRAM: ~S" object)))) + cookie + &rest keys + &key direction (external-format :default) wait + &allow-other-keys) + (declare (ignore wait)) ;This is explained below. + ;; Our use of a temporary file dates back to very old CMUCLs, and + ;; was probably only ever intended for use with STRING-STREAMs, + ;; which are ordinarily smallish. However, as we've got + ;; user-defined stream classes, we can end up trying to copy + ;; arbitrarily much data into the temp file, and so are liable to + ;; run afoul of disk quotas or to choke on small /tmp file systems. + (flet ((make-temp-fd () + (multiple-value-bind (fd name/errno) + (sb-unix:sb-mkstemp (format nil "~a/.run-program-XXXXXX" + (get-temporary-directory)) + #o0600) + (unless fd + (error "could not open a temporary file: ~A" + (strerror name/errno))) + ;; Can't unlink an open file on Windows + #-win32 + (unless (sb-unix:unix-unlink name/errno) + (sb-unix:unix-close fd) + (error "failed to unlink ~A" name/errno)) + fd))) + (let ((dev-null #.(coerce #-win32 "/dev/null" #+win32 "nul" 'base-string))) + (cond ((eq object t) + ;; No new descriptor is needed. + (values -1 nil)) + ((or (eq object nil) + (and (typep object 'broadcast-stream) + (not (broadcast-stream-streams object)))) + ;; Use /dev/null. + (multiple-value-bind + (fd errno) + (sb-unix:unix-open dev-null + (case direction + (:input sb-unix:o_rdonly) + (:output sb-unix:o_wronly) + (t sb-unix:o_rdwr)) + #o666) + (unless fd + (error "~@" + dev-null (strerror errno))) + #+win32 + (setf (sb-win32::inheritable-handle-p fd) t) + (push fd *close-in-parent*) + (values fd nil))) + ((eq object :stream) + (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe) + (unless read-fd + (error "couldn't create pipe: ~A" (strerror write-fd))) + #+win32 + (setf (sb-win32::inheritable-handle-p read-fd) + (eq direction :input) + (sb-win32::inheritable-handle-p write-fd) + (eq direction :output)) + (case direction + (:input + (push read-fd *close-in-parent*) + (push write-fd *close-on-error*) + (let ((stream (make-fd-stream write-fd :output t + :element-type :default + :external-format + external-format))) + (values read-fd stream))) + (:output + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (let ((stream (make-fd-stream read-fd :input t + :element-type :default + :external-format + external-format))) + (values write-fd stream))) + (t + (sb-unix:unix-close read-fd) + (sb-unix:unix-close write-fd) + (error "Direction must be either :INPUT or :OUTPUT, not ~S." + direction))))) + ((or (pathnamep object) (stringp object)) + ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather + ;; than munge the &rest list for OPEN, just disable keyword + ;; validation there. + (with-open-stream (file (apply #'open object :allow-other-keys t + keys)) + (when file + (multiple-value-bind + (fd errno) + (sb-unix:unix-dup (fd-stream-fd file)) + (cond (fd + (push fd *close-in-parent*) + (values fd nil)) + (t + (error "couldn't duplicate file descriptor: ~A" + (strerror errno)))))))) + ((streamp object) + (ecase direction + (:input + (block nil + ;; If we can get an fd for the stream, let the child + ;; process use the fd for its descriptor. Otherwise, + ;; we copy data from the stream into a temp file, and + ;; give the temp file's descriptor to the + ;; child. + (multiple-value-bind (fd stream format) + (get-stream-fd-and-external-format object :input) + (declare (ignore format)) + (when fd + (return (values fd stream)))) + ;; FIXME: if we can't get the file descriptor, since + ;; the stream might be interactive or otherwise + ;; block-y, we can't know whether we can copy the + ;; stream's data to a temp file, so if RUN-PROGRAM was + ;; called with :WAIT NIL, we should probably error. + ;; However, STRING-STREAMs aren't fd-streams, but + ;; they're not prone to blocking; any user-defined + ;; streams that "read" from some in-memory data will + ;; probably be similar to STRING-STREAMs. So maybe we + ;; should add a STREAM-INTERACTIVE-P generic function + ;; for problems like this? Anyway, the machinery is + ;; here, if you feel like filling in the details. + #| + (when (and (null wait) #) + (error "~@" object)) + |# + (let ((fd (make-temp-fd)) + (et (stream-element-type object))) + (cond ((member et '(character base-char)) + (loop + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (let ((vector (string-to-octets + line + :external-format external-format))) + (sb-unix:unix-write + fd vector 0 (length vector))) + (if no-cr + (return) + (sb-unix:unix-write + fd #.(string #\Newline) 0 1))))) + ((member et '(:default (unsigned-byte 8)) + :test 'equal) + (loop with buf = (make-array 256 :element-type '(unsigned-byte 8)) + for p = (read-sequence buf object) + until (zerop p) + do (sb-unix:unix-write fd buf 0 p))) + (t + (error "Don't know how to copy from stream of element-type ~S" + et))) + (sb-unix:unix-lseek fd 0 sb-unix:l_set) + (push fd *close-in-parent*) + (return (values fd nil))))) + (:output + (block nil + ;; Similar to the :input trick above, except we + ;; arrange to copy data from the stream. This is + ;; slightly saner than the input case, since we don't + ;; buffer to a file, but I think we may still lose if + ;; there's unflushed data in the stream buffer and we + ;; give the file descriptor to the child. + (multiple-value-bind (fd stream format) + (get-stream-fd-and-external-format object :output) + (declare (ignore format)) + (when fd + (return (values fd stream)))) + (multiple-value-bind (read-fd write-fd) + (sb-unix:unix-pipe) + (unless read-fd + (error "couldn't create pipe: ~S" (strerror write-fd))) + (copy-descriptor-to-stream read-fd object cookie + external-format) + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (return (values write-fd nil))))) + (t + (error "invalid option to RUN-PROGRAM: ~S" object))))))))