;;; 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))
(sb-sys:serve-all-events 1))
process)
-#-(or hpux win32)
+#-win32
;;; Find the current foreground process group id.
(defun find-current-foreground-process (proc)
(with-alien ((result sb-alien:int))
((:pid :process-group)
(process-pid process))
(:pty-process-group
- #-hpux
(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 process))
- sb-unix:TIOCSIGSEND
- (sb-sys:int-sap
- signal)))
- ((:process-group #-hpux :pty-process-group)
+ ((:process-group)
(sb-unix:unix-killpg pid signal))
(t
(sb-unix:unix-kill pid signal)))
;;; 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)
(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
;; 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))
projects / sbcl.git / blobdiff