;;; accesses it, that's why we need without-interrupts.
(defmacro with-active-processes-lock (() &body body)
#-win32
- `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*)
+ `(sb-thread::with-system-mutex (*active-processes-lock* :allow-with-interrupts t)
+ ,@body)
#+win32
`(progn ,@body))
;;; 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.
-#-win32
+#-(or win32 openbsd)
(progn
(define-alien-routine ptsname c-string (fd int))
(define-alien-routine grantpt boolean (fd int))
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)
;; 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-bytes-to-words (1+ size))))
+ (setf string-sap (sap+ string-sap (round-bytes-to-words size)))
(incf vec-index-offset bytes-per-word)))
;; Final null pointer.
(setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0))
,@body)
(sb-sys:deallocate-system-memory ,sap ,size)))))
-#-win32
-(sb-alien:define-alien-routine ("spawn" %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))
-
-#+win32
-(sb-alien:define-alien-routine ("spawn" %spawn) sb-win32::handle
+(sb-alien:define-alien-routine spawn
+ #-win32 sb-alien:int
+ #+win32 sb-win32::handle
(program sb-alien:c-string)
(argv (* sb-alien:c-string))
(stdin sb-alien:int)
(stdout sb-alien:int)
(stderr sb-alien:int)
+ (search sb-alien:int)
+ (envp (* sb-alien:c-string))
+ (pty-name sb-alien:c-string)
(wait sb-alien:int))
-(defun spawn (program argv stdin stdout stderr envp pty-name wait)
- #+win32 (declare (ignore envp pty-name))
- #+win32 (%spawn program argv stdin stdout stderr (if wait 1 0))
- #-win32 (declare (ignore wait))
- #-win32 (%spawn program argv envp pty-name stdin stdout stderr))
-
-;;; FIXME: why are we duplicating standard library stuff and not using
-;;; execvp(3)? We can extend our internal spawn() routine to take a
-;;; flag to say whether to search...
-;;; Is UNIX-FILENAME the name of a file that we can execute?
-(defun unix-filename-is-executable-p (unix-filename)
- (let ((filename (coerce unix-filename 'string)))
- (values (and (eq (sb-unix:unix-file-kind filename) :file)
- #-win32
- (sb-unix:unix-access filename sb-unix:x_ok)))))
-
-(defun find-executable-in-search-path (pathname &optional
- (search-path (posix-getenv "PATH")))
- #+sb-doc
- "Find the first executable file matching PATHNAME in any of the
-colon-separated list of pathnames SEARCH-PATH"
- (let ((program #-win32 pathname
- #+win32 (merge-pathnames pathname (make-pathname :type "exe"))))
- (loop for end = (position #-win32 #\: #+win32 #\; search-path
- :start (if end (1+ end) 0))
- and start = 0 then (and end (1+ end))
- while start
- ;; <Krystof> 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
- (unix-namestring (merge-pathnames program truename)))
- when (and fullpath (unix-filename-is-executable-p 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
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
+ Look for PROGRAM in each of the directories in the child's $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."#-win32"
#-win32 *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 (simplify-args args))
- ;; See the comment above about execlp(3).
- (pfile (if search
- (find-executable-in-search-path program)
- (unix-namestring program)))
+ (progname (native-namestring program))
;; Gag.
(cookie (list 0)))
- (unless pfile
- (error "no such program: ~S" program))
- (unless (unix-filename-is-executable-p pfile)
- (error "not executable: ~S" program))
(unwind-protect
+ ;; 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)
input cookie
:direction :input
:if-does-not-exist if-input-does-not-exist
- :external-format :default)
+ :external-format :default
+ :wait wait)
(with-fd-and-stream-for ((stdout output-stream) :output
output cookie
:direction :output
(with-environment-vec (environment-vec environment)
(let ((child
(without-gcing
- (spawn pfile args-vec
+ (spawn progname args-vec
stdin stdout stderr
- environment-vec pty-name wait))))
- (when (minusp child)
+ (if search 1 0)
+ environment-vec pty-name
+ (if wait 1 0)))))
+ (when (= child -1)
(error "couldn't fork child process: ~A"
(strerror)))
(setf proc (apply
#-win32
(dolist (handler *handlers-installed*)
(sb-sys:remove-fd-handler handler))))
+ #-win32
(when (and wait proc)
(process-wait proc))
proc)))
(ash 1 descriptor)
0 0 0)
(cond ((null result)
- (error "~@<couldn't select on sub-process: ~
- ~2I~_~A~:>"
- (strerror readable/errno)))
+ (if (eql sb-unix:eintr readable/errno)
+ (return)
+ (error "~@<Couldn't select on sub-process: ~
+ ~2I~_~A~:>"
+ (strerror readable/errno))))
((zerop result)
(return))))
(multiple-value-bind (count errno)
(setf handler nil)
(decf (car cookie))
(sb-unix:unix-close descriptor)
+ (unless (zerop read-end)
+ ;; Should this be an END-OF-FILE?
+ (error "~@<non-empty buffer when EOF reached ~
+ while reading from child: ~S~:>" buf))
(return))
((null count)
(sb-sys:remove-fd-handler handler)
(strerror errno)))
(t
(incf read-end count)
- (let* ((decode-end (length buf))
+ (let* ((decode-end read-end)
(string (handler-case
(octets-to-string
buf :end read-end
(replace buf buf :start2 decode-end :end2 read-end))
(decf read-end decode-end))))))))))))
+;;; 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
(sb-sys:fd-stream
(defun get-descriptor-for (object
cookie
&rest keys
- &key direction external-format
+ &key direction (external-format :default) wait
&allow-other-keys)
- ;; Someday somebody should review our use of the temporary file: are
- ;; we doing something that's liable to run afoul of disk quotas or
- ;; to choke on small /tmp file systems?
+ (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:unix-mkstemp "/tmp/.run-program-XXXXXX")
+ (sb-unix:sb-mkstemp "/tmp/.run-program-XXXXXX" #o0600)
(unless fd
(error "could not open a temporary file: ~A"
(strerror name/errno)))
- #-win32 #|FIXME: should say (logior s_irusr s_iwusr)|#
- (unless (sb-unix:unix-chmod name/errno #o600)
- (sb-unix:unix-close fd)
- (error "failed to chmod the temporary file?!"))
(unless (sb-unix:unix-unlink name/errno)
(sb-unix:unix-close fd)
(error "failed to unlink ~A" name/errno))
(error "Direction must be either :INPUT or :OUTPUT, not ~S."
direction)))))
((or (pathnamep object) (stringp object))
- (with-open-stream (file (apply #'open object keys))
+ ;; 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))
(multiple-value-bind
(fd errno)
(sb-unix:unix-dup (sb-sys:fd-stream-fd file))
(error "couldn't duplicate file descriptor: ~A"
(strerror errno)))))))
((streamp object)
- ;; XXX: what is the correct way to compare external formats?
(ecase direction
(:input
- (or
- ;; If we can get an fd for the stream and the
- ;; stream's external format is the default, 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)
- (when (and fd format
- (eq (find-external-format
- *default-external-format*)
- (find-external-format format)))
- (values fd stream)))
- (let ((fd (make-temp-fd))
- (newline (string #\Newline)))
- (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 newline 0 1))))
- (sb-unix:unix-lseek fd 0 sb-unix:l_set)
- (push fd *close-in-parent*)
- (values fd nil))))
+ (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) #<some undetermined criterion>)
+ (error "~@<don't know how to get an fd for ~A, and so ~
+ can't ensure that copying its data to the ~
+ child process won't hang~:>" object))
+ |#
+ (let ((fd (make-temp-fd))
+ (newline (string #\Newline)))
+ (loop
+ (multiple-value-bind
+ (line no-cr)
+ (read-line object nil nil)
+ (unless line
+ (return))
+ (let ((vector (string-to-octets line)))
+ (sb-unix:unix-write
+ fd vector 0 (length vector)))
+ (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
- (or
- ;; Similar to the :input trick above, except we
- ;; arrange to copy data from the stream. This is
- ;; only slightly less sleazy than the input case,
- ;; since we don't buffer to a file, but I think we
- ;; may still lose if there's data in the stream
- ;; buffer.
- (multiple-value-bind (fd stream format)
- (get-stream-fd-and-external-format object :output)
- (when (and fd format (eq (find-external-format
- *default-external-format*)
- (find-external-format format)))
- (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*)
- (values write-fd nil))))))
+ (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)))))
projects / sbcl.git / blobdiff