;;;; 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.)
\f
;;;; hacking the Unix environment
;;;;
;;;; visible at GENESIS time.
(def-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.)
+ (def-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.
(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
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))
(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)
(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))
(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*)))))))))
\f
;;;; 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
(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)
(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 ~D: ~A" master (strerror errno)))
(push new-fd *close-on-error*)
(copy-descriptor-to-stream new-fd pty cookie)))
(values name
(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))
;; 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))
;; Blast the pointer to the string into place.
(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
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
(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
*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:"),
;; "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)
;; 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
(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)))
+ (error "~@<couldn't select on sub-process: ~
+ ~2I~_~A~:>"
+ (strerror readable/errno)))
((zerop result)
(return))))
(sb-alien:with-alien ((buf (sb-alien:array
(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)))
+ (error
+ "~@<couldn't read input from sub-process: ~
+ ~2I~_~A~:>"
+ (strerror errno)))
(t
(sb-kernel:copy-from-system-area
(alien-sap buf) 0
string (* sb-vm:vector-data-offset
- sb-vm:word-bits)
+ sb-vm:n-word-bits)
(* count sb-vm:byte-bits))
(write-string string stream
:end count)))))))))))
(t sb-unix:o_rdwr))
#o666)
(unless fd
- (error "could not open \"/dev/null\": ~S"
- (sb-unix:get-unix-error-msg errno)))
+ (error "~@<couldn't open \"/dev/null\": ~2I~_~A~:>"
+ (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*)
(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)
(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*)
projects / sbcl.git / blobdiff