X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=f8a36a133bf6b0eced90a3e4c04435a98e08c523;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=d4f64370b36a6ac335dcc9a321501ce37622ff93;hpb=4035ca5bf8b101d2e35b8e14a079b930d21fb7af;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index d4f6437..f8a36a1 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -154,7 +154,8 @@ ;;; 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)) @@ -248,7 +249,7 @@ PROCESS." (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)) @@ -273,18 +274,11 @@ PROCESS." ((: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))) @@ -390,7 +384,7 @@ status slot." ;;; 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)) @@ -437,6 +431,21 @@ status slot." 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) @@ -489,7 +498,7 @@ status slot." ;; 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)) @@ -504,61 +513,19 @@ status slot." ,@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 - ;; 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 @@ -659,9 +626,8 @@ Users Manual for details about the PROCESS structure."#-win32" 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" @@ -739,20 +705,15 @@ Users Manual for details about the PROCESS structure."#-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) @@ -803,10 +764,12 @@ Users Manual for details about the PROCESS structure."#-win32" (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 @@ -833,6 +796,7 @@ Users Manual for details about the PROCESS structure."#-win32" #-win32 (dolist (handler *handlers-installed*) (sb-sys:remove-fd-handler handler)))) + #-win32 (when (and wait proc) (process-wait proc)) proc))) @@ -860,9 +824,11 @@ Users Manual for details about the PROCESS structure."#-win32" (ash 1 descriptor) 0 0 0) (cond ((null result) - (error "~@" - (strerror readable/errno))) + (if (eql sb-unix:eintr readable/errno) + (return) + (error "~@" + (strerror readable/errno)))) ((zerop result) (return)))) (multiple-value-bind (count errno) @@ -879,6 +845,10 @@ Users Manual for details about the PROCESS structure."#-win32" (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) (sb-sys:remove-fd-handler handler) @@ -890,7 +860,7 @@ Users Manual for details about the PROCESS structure."#-win32" (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 @@ -947,14 +917,10 @@ Users Manual for details about the PROCESS structure."#-win32" ;; 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)) @@ -1006,7 +972,11 @@ Users Manual for details about the PROCESS structure."#-win32" (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))