X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=0808fdde7728d4aa710d5912565c240a1eae9846;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=7db3ff5427609972940aff81f27aaa6e5525a12e;hpb=1ff04b3ba4e6f3a0fc6ceea524e98720ecea7888;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 7db3ff5..0808fdd 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -10,34 +10,108 @@ ;;;; 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.) -;;;; Import wait3(2) from Unix. +;;;; 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. + +(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))) + +;;; Convert as best we can from an SBCL representation of a Unix +;;; environment to a CMU CL representation. +;;; +;;; * (UNIX-ENVIRONMENT-CMUCL-FROM-SBCL '("Bletch=fub" "Noggin" "YES=No!")) +;;; WARNING: +;;; smashing case of "Bletch=fub" in conversion to CMU-CL-style +;;; environment alist +;;; WARNING: +;;; no #\= in "Noggin", eliding it in CMU-CL-style environment alist +;;; ((:BLETCH . "fub") (:YES . "No!")) +(defun unix-environment-cmucl-from-sbcl (sbcl) + (mapcan + (lambda (string) + (declare (type simple-base-string string)) + (let ((=-pos (position #\= string :test #'equal))) + (if =-pos + (list + (let* ((key-as-string (subseq string 0 =-pos)) + (key-as-upcase-string (string-upcase key-as-string)) + (key (keywordicate key-as-upcase-string)) + (val (subseq string (1+ =-pos)))) + (unless (string= key-as-string key-as-upcase-string) + (warn "smashing case of ~S in conversion to CMU-CL-style ~ + environment alist" + string)) + (cons key val))) + (warn "no #\\= in ~S, eliding it in CMU-CL-style environment alist" + string)))) + sbcl)) -(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)) +;;; 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) (type simple-base-string val)) + (concatenate 'simple-base-string (symbol-name key) "=" val))) + cmucl)) + +;;;; Import wait3(2) from Unix. -(defconstant wait-wnohang #-svr4 1 #+svr4 #o100) -(defconstant wait-wuntraced #-svr4 2 #+svr4 4) -(defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced) +(define-alien-routine ("wait3" c-wait3) sb-alien:int + (status sb-alien:int :out) + (options sb-alien:int) + (rusage sb-alien:int)) (defun wait3 (&optional do-not-hang check-for-stopped) "Return any available status information on child process. " (multiple-value-bind (pid status) (c-wait3 (logior (if do-not-hang - wait-wnohang + sb-unix:wnohang 0) (if check-for-stopped - wait-wuntraced + sb-unix:wuntraced 0)) 0) (cond ((or (minusp pid) (zerop pid)) nil) ((eql (ldb (byte 8 0) status) - wait-wstopped) + sb-unix:wstopped) (values pid :stopped (ldb (byte 8 8) status))) @@ -48,10 +122,12 @@ (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)) + (if (position signal + #.(vector + sb-unix:sigstop + sb-unix:sigtstp + sb-unix:sigttin + sb-unix:sigttou)) :stopped :signaled) signal @@ -62,7 +138,7 @@ (defvar *active-processes* nil "List of process structures for all active processes.") -(defstruct (process) +(defstruct (process (:copier nil)) pid ; PID of child process %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED exit-code ; either exit code or signal @@ -78,7 +154,7 @@ (defmethod print-object ((process process) stream) (print-unreadable-object (process stream :type t) (format stream - "~D ~S" + "~W ~S" (process-pid process) (process-status process))) process) @@ -106,15 +182,14 @@ #-hpux ;;; 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 sb-alien: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))) + (alien-sap (sb-alien: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)) @@ -137,7 +212,7 @@ (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)))) + signal))) ((:process-group #-hpux :pty-process-group) (sb-unix:unix-killpg pid signal)) (t @@ -145,7 +220,7 @@ (cond ((not okay) (values nil errno)) ((and (eql pid (process-pid proc)) - (= (sb-unix:unix-signal-number signal) sb-unix:sigcont)) + (= signal sb-unix:sigcont)) (setf (process-%status proc) :running) (setf (process-exit-code proc) nil) (when (process-status-hook proc) @@ -174,7 +249,7 @@ (setf *active-processes* (delete proc *active-processes*))) proc) -;;; the handler for sigchld signals that RUN-PROGRAM establishes +;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes (defun sigchld-handler (ignore1 ignore2 ignore3) (declare (ignore ignore1 ignore2 ignore3)) (get-processes-status-changes)) @@ -192,81 +267,38 @@ (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)) + (when (position what #(:exited :signaled)) (sb-sys:without-interrupts (setf *active-processes* (delete proc *active-processes*))))))))) ;;;; 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 -#+OpenBSD -(def-alien-type nil - (struct sgttyb - (sg-four sb-c-call:int) - (sg-chars (array sb-c-call:char 4)) - (sg-flags sb-c-call:int))) - -;;; 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. +;;; 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 +(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. (defun find-a-pty () (dolist (char '(#\p #\q)) (dotimes (digit 16) - (let* ((master-name (format nil "/dev/pty~C~X" char digit)) + (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) 'base-string)) (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)) + (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) 'base-string)) (slave-fd (sb-unix:unix-open slave-name sb-unix:o_rdwr #o666))) (when slave-fd - ;; comment from classic CMU CL: - ;; Maybe put a vhangup here? - ;; - ;; FIXME: It seems as though this logic should be in - ;; OPEN-PTY, not FIND-A-PTY (both from the comments - ;; documenting DEFUN FIND-A-PTY, and from the - ;; connotations of the function names). - ;; - ;; FIXME: It would be nice to have a note, and/or a pointer - ;; to some reference material somewhere, explaining - ;; why we need this on *BSD and not on Linux. - #+bsd - (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) - ;; This is EVENP|ODDP, the same numeric code - ;; both on FreeBSD and on OpenBSD. -- WHN 20000929 - #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) - ;; This is ~ECHO, the same numeric - ;; code both on FreeBSD and on OpenBSD. - ;; -- WHN 20000929 - (lognot 8))) ; ~ECHO - (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap))) (return-from find-a-pty (values master-fd slave-fd @@ -284,8 +316,7 @@ (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))) + (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))) (values name @@ -300,38 +331,42 @@ (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)))) + (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits) + (+ (length string-list) 2)))) (declare (fixnum string-bytes vec-bytes)) (dolist (s string-list) - (check-type s simple-string) + (enforce-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)) + (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))) (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-kernel:copy-to-system-area (the simple-base-string + ;; FIXME + (coerce s 'simple-base-string)) (* sb-vm:vector-data-offset - sb-vm:word-bits) + sb-vm:n-word-bits) string-sap 0 - (* (1+ n) sb-vm:byte-bits)) + (* (1+ n) sb-vm:n-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))) + (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))) ;; 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)))) + (values vec-sap (sap+ vec-sap #.(/ sb-vm::n-machine-word-bits + sb-vm::n-byte-bits)) + total-bytes)))) (defmacro with-c-strvec ((var str-list) &body body) - (let ((sap (gensym "SAP-")) - (size (gensym "SIZE-"))) + (with-unique-names (sap size) `(multiple-value-bind (,sap ,var ,size) (string-list-to-c-strvec ,str-list) @@ -340,15 +375,44 @@ ,@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)) +(sb-alien:define-alien-routine spawn sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string)) + (envp (* sb-alien:c-string)) + (pty-name sb-alien:c-string) + (stdin sb-alien:int) + (stdout sb-alien:int) + (stderr sb-alien:int)) + +;;; Is UNIX-FILENAME the name of a file that we can execute? +(defun unix-filename-is-executable-p (unix-filename) + (declare (type simple-string unix-filename)) + (setf unix-filename (coerce unix-filename 'base-string)) + (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) + (sb-unix:unix-access unix-filename sb-unix:x_ok)))) + +(defun find-executable-in-search-path (pathname + &optional + (search-path (posix-getenv "PATH"))) + "Find the first executable file matching PATHNAME in any of the colon-separated list of pathnames SEARCH-PATH" + (loop for end = (position #\: search-path :start (if end (1+ end) 0)) + and start = 0 then (and end (1+ end)) + while start + ;; the truename of a file naming a directory is the + ;; directory, at least until pfdietz comes along and says why + ;; that's noncompliant -- CSR, c. 2003-08-10 + for truename = (probe-file (subseq search-path start end)) + for fullpath = (when truename (merge-pathnames pathname truename)) + when (and fullpath + (unix-filename-is-executable-p (namestring fullpath))) + return fullpath)) +;;; 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. @@ -387,21 +451,53 @@ ;;; 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). + &key + (env nil env-p) + (environment (if env-p + (unix-environment-sbcl-from-cmucl env) + (posix-environ)) + environment-p) + (wait t) + search + 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 Unix process running the Unix program found in + the file specified by the PROGRAM argument. ARGS are the standard + arguments that can be passed to a Unix program. For no arguments, use NIL + (which means that 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: + notes about Unix environments (as in the :ENVIRONMENT and :ENV args): + 1. 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. + 2. 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 SIMPLE-BASE-STRINGs describing the new Unix environment + (as in \"man environ\"). The default is to copy the environment of + the current process. :ENV - An A-LIST mapping keyword environment variables to simple-string - values. + an alternative lossy representation of the new Unix environment, + for compatibility with CMU CL + :SEARCH + Look for PROGRAM in each of the directories along the $PATH + environment variable. Otherwise an absolute pathname is required. + (See also FIND-EXECUTABLE-IN-SEARCH-PATH) :WAIT If non-NIL (default), wait until the created process finishes. If NIL, continue running Lisp until the program finishes. @@ -443,35 +539,46 @@ This is a function the system calls whenever the status of the process changes. The function takes the process as an argument." + (when (and env-p environment-p) + (error "can't specify :ENV and :ENVIRONMENT simultaneously")) ;; Make sure that the interrupt handler is installed. (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler) - ;; Make sure that all the args are okay. - (unless (every #'simple-string-p args) - (error "All arguments to program must be simple strings: ~S" args)) ;; Prepend 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) + (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to + ;; communicate cleanup info. + *close-on-error* + *close-in-parent* + *handlers-installed* + ;; Establish PROC at this level so that we can return it. + proc + ;; It's friendly to allow the caller to pass any string + ;; designator, but internally we'd like SIMPLE-STRINGs. + (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args))) (unwind-protect - (let ((pfile (unix-namestring (merge-pathnames program "path:") t t)) + (let ((pfile + (if search + (let ((p (find-executable-in-search-path program))) + (and p (unix-namestring p t))) + (unix-namestring program 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 + (unless (unix-filename-is-executable-p pfile) + (error "not executable: ~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 + (multiple-value-bind (stdout output-stream) + (get-descriptor-for output cookie + :direction :output :if-exists if-output-exists) - (multiple-value-bind - (stderr error-stream) + (multiple-value-bind (stderr error-stream) (if (eq error :output) (values stdout output-stream) - (get-descriptor-for error cookie :direction :output + (get-descriptor-for error cookie + :direction :output :if-exists if-error-exists)) (multiple-value-bind (pty-name pty-stream) (open-pty pty cookie) @@ -479,22 +586,15 @@ ;; 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)) + (with-c-strvec (args-vec simple-args) + (with-c-strvec (environment-vec environment) (let ((child-pid (without-gcing - (spawn pfile argv envp pty-name + (spawn pfile args-vec environment-vec pty-name stdin stdout stderr)))) (when (< child-pid 0) - (error "could not fork child process: ~S" - (sb-unix:get-unix-error-msg))) + (error "couldn't fork child process: ~A" + (strerror))) (setf proc (make-process :pid child-pid :%status :running :pty pty-stream @@ -520,57 +620,59 @@ ;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) - (let ((string (make-string 256)) + (let ((string (make-string 256 :element-type 'base-char)) handler) (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))))))))))) + :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 "~@" + (strerror readable/errno))) + ((zerop result) + (return)))) + (sb-alien:with-alien ((buf (sb-alien:array + sb-alien: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 + "~@" + (strerror errno))) + (t + (sb-kernel:copy-from-system-area + (alien-sap buf) 0 + string (* sb-vm:vector-data-offset + sb-vm:n-word-bits) + (* count sb-vm:n-byte-bits)) + (write-string string stream + :end count))))))))))) ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created @@ -587,24 +689,21 @@ ;; Use /dev/null. (multiple-value-bind (fd errno) - (sb-unix:unix-open "/dev/null" + (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) (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))) + (error "~@" + (strerror errno))) (push fd *close-in-parent*) (values fd nil))) ((eq object :stream) - (multiple-value-bind - (read-fd write-fd) - (sb-unix:unix-pipe) + (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))) + (error "couldn't create pipe: ~A" (strerror write-fd))) (case direction (:input (push read-fd *close-in-parent*) @@ -630,8 +729,8 @@ (push fd *close-in-parent*) (values fd nil)) (t - (error "could not duplicate file descriptor: ~S" - (sb-unix:get-unix-error-msg errno))))))) + (error "couldn't duplicate file descriptor: ~A" + (strerror errno))))))) ((sb-sys:fd-stream-p object) (values (sb-sys:fd-stream-fd object) nil)) ((streamp object) @@ -642,7 +741,7 @@ (dotimes (count 256 (error "could not open a temporary file in /tmp")) - (let* ((name (format nil "/tmp/.run-program-~D" count)) + (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string)) (fd (sb-unix:unix-open name (logior sb-unix:o_rdwr sb-unix:o_creat @@ -657,7 +756,16 @@ (read-line object nil nil) (unless line (return)) - (sb-unix:unix-write fd line 0 (length line)) + (sb-unix:unix-write + fd + ;; FIXME: this really should be + ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...). + ;; RUN-PROGRAM should take an + ;; external-format argument, which should + ;; be passed down to here. Something + ;; similar should happen on :OUTPUT, too. + (map '(vector (unsigned-byte 8)) #'char-code line) + 0 (length line)) (if no-cr (return) (sb-unix:unix-write fd newline 0 1))))) @@ -668,8 +776,7 @@ (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))) + (error "couldn't create pipe: ~S" (strerror write-fd))) (copy-descriptor-to-stream read-fd object cookie) (push read-fd *close-on-error*) (push write-fd *close-in-parent*)