X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=4dbcc554a526232a9de09f9b10708cf3180bfe3f;hb=e0814eee6f6dea52db010b45a330100f2fe65832;hp=59b2e6ee729f241a6771084fabf2a0d620270347;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 59b2e6e..4dbcc55 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -10,7 +10,7 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-IMPL") +(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) ;;;; hacking the Unix environment ;;;; @@ -45,17 +45,26 @@ ;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not ;;;; visible at GENESIS time. -(def-alien-variable "environ" (* c-string)) +(define-alien-variable "environ" (* c-string)) +(push (lambda () + ;; We redo this here to protect ourselves from this scenario: + ;; * Build under one version of shared lib, save a core. + ;; * Load core under another version of shared lib. ("Now + ;; where was environ again?" SIGSEGV, etc.) + ;; Obviously it's a KLUDGE to do this hack for every alien + ;; variable, but as it happens, as of sbcl-0.7.0 this is the + ;; only alien variable used to implement SBCL, so it's not + ;; worth coming up with a general solution. (A general + ;; solution would be nice for users who want to have their + ;; alien code be preserved across a save/load cycle, but this + ;; problem with alien variables is only one of several + ;; problems which'd need to be solved before that can happen.) + (define-alien-variable "environ" (* c-string))) + *after-save-initializations*) (defun posix-environ () "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs." - (let ((reversed-result nil)) - (dotimes (i most-positive-fixnum (error "can't happen")) - (declare (type index i)) - (let ((env-item (deref environ i))) - (if env-item - (push env-item reversed-result) - (return (nreverse reversed-result))))))) + (c-strings->string-list environ)) ;;; Convert as best we can from a SBCL representation of a Unix ;;; environment to a CMU CL representation. @@ -99,7 +108,7 @@ ;;;; Import wait3(2) from Unix. -(sb-alien:def-alien-routine ("wait3" c-wait3) sb-c-call:int +(sb-alien:define-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)) @@ -133,10 +142,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:unix-signal-number :sigstop) + (sb-unix:unix-signal-number :sigtstp) + (sb-unix:unix-signal-number :sigttin) + (sb-unix:unix-signal-number :sigttou))) :stopped :signaled) signal @@ -163,7 +174,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) @@ -198,8 +209,7 @@ sb-unix:TIOCGPGRP (sb-alien: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)) @@ -230,7 +240,8 @@ (cond ((not okay) (values nil errno)) ((and (eql pid (process-pid proc)) - (= (sb-unix:unix-signal-number signal) sb-unix:sigcont)) + (= (sb-unix:unix-signal-number signal) + (sb-unix:unix-signal-number :sigcont))) (setf (process-%status proc) :running) (setf (process-exit-code proc) nil) (when (process-status-hook proc) @@ -259,7 +270,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)) @@ -277,23 +288,24 @@ (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.") +;;; 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) #+FreeBSD -(def-alien-type nil +(define-alien-type nil (struct sgttyb (sg-ispeed sb-c-call:char) ; input speed (sg-ospeed sb-c-call:char) ; output speed @@ -301,16 +313,15 @@ (sg-kill sb-c-call:char) ; kill character (sg-flags sb-c-call:short))) ; mode flags #+OpenBSD -(def-alien-type nil +(define-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. +;;; 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) @@ -369,8 +380,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 @@ -388,7 +398,7 @@ (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) + (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)) @@ -403,9 +413,9 @@ ;; Blast the string into place. (sb-kernel:copy-to-system-area (the simple-string s) (* 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)))) @@ -425,7 +435,7 @@ ,@body) (sb-sys:deallocate-system-memory ,sap ,size))))) -(sb-alien:def-alien-routine spawn sb-c-call:int +(sb-alien:define-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)) @@ -434,6 +444,12 @@ (stdout sb-c-call:int) (stderr sb-c-call: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)) + (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) + (sb-unix:unix-access unix-filename sb-unix:x_ok)))) + ;;; 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 @@ -512,7 +528,7 @@ documentation about this and other security issues in script-like programs.) - The keyword arguments have the following meanings: + The &KEY arguments have the following meanings: :ENVIRONMENT a list of SIMPLE-STRINGs describing the new Unix environment (as in \"man environ\"). The default is to copy the environment of @@ -564,10 +580,7 @@ (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)) + (sb-sys:enable-interrupt :sigchld #'sigchld-handler) ;; Prepend the program to the argument list. (push (namestring program) args) (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to @@ -576,7 +589,10 @@ *close-in-parent* *handlers-installed* ;; Establish PROC at this level so that we can return it. - proc) + 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 (;; FIXME: The old code here used to do ;; (MERGE-PATHNAMES PROGRAM "path:"), @@ -585,23 +601,28 @@ ;; "path:" defined in sbcl-0.6.10. It would probably be ;; reasonable to restore Unix PATH searching in SBCL, e.g. ;; with a function FIND-EXECUTABLE-FILE-IN-POSIX-PATH. - ;; (I don't want to do it with search lists the way - ;; that CMU CL did, because those are a non-ANSI - ;; extension which I'd like to get rid of. -- WHN) - (pfile (unix-namestring program t t)) + ;; CMU CL did it with a "PATH:" search list, but CMU CL + ;; search lists are a non-ANSI extension that SBCL + ;; doesn't support. -- WHN) + (pfile (unix-namestring program t)) (cookie (list 0))) (unless pfile (error "no such program: ~S" program)) + (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 + (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 + (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 + (get-descriptor-for error cookie + :direction :output :if-exists if-error-exists)) (multiple-value-bind (pty-name pty-stream) (open-pty pty cookie) @@ -609,15 +630,15 @@ ;; death before we have installed the PROCESS ;; structure in *ACTIVE-PROCESSES*. (sb-sys:without-interrupts - (with-c-strvec (args-vec args) + (with-c-strvec (args-vec simple-args) (with-c-strvec (environment-vec environment) (let ((child-pid (without-gcing (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 @@ -648,52 +669,54 @@ (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-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 + "~@" + (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 @@ -717,17 +740,14 @@ (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*) @@ -753,8 +773,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) @@ -791,8 +811,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*)