"Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs."
(c-strings->string-list (wrapped-environ)))
-;;; Convert as best we can from a SBCL representation of a Unix
+;;; Convert as best we can from an SBCL representation of a Unix
;;; environment to a CMU CL representation.
;;;
;;; * (UNIX-ENVIRONMENT-CMUCL-FROM-SBCL '("Bletch=fub" "Noggin" "YES=No!"))
(defun unix-environment-cmucl-from-sbcl (sbcl)
(mapcan
(lambda (string)
- (declare (type simple-string string))
+ (declare (type simple-base-string string))
(let ((=-pos (position #\= string :test #'equal)))
(if =-pos
(list
(mapcar
(lambda (cons)
(destructuring-bind (key . val) cons
- (declare (type keyword key) (type simple-string val))
- (concatenate 'simple-string (symbol-name key) "=" val)))
+ (declare (type keyword key) (type simple-base-string val))
+ (concatenate 'simple-base-string (symbol-name key) "=" val)))
cmucl))
\f
;;;; Import wait3(2) from Unix.
(options sb-alien:int)
(rusage sb-alien:int))
-(defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
-(defconstant wait-wuntraced #-svr4 2 #+svr4 4)
-(defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced)
-
(defun wait3 (&optional do-not-hang check-for-stopped)
"Return any available status information on child process. "
(multiple-value-bind (pid status)
(c-wait3 (logior (if do-not-hang
- wait-wnohang
+ sb-unix:wnohang
0)
(if check-for-stopped
- wait-wuntraced
+ sb-unix:wuntraced
0))
0)
(cond ((or (minusp pid)
(zerop pid))
nil)
((eql (ldb (byte 8 0) status)
- wait-wstopped)
+ sb-unix:wstopped)
(values pid
:stopped
(ldb (byte 8 8) status)))
(values pid
(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)))
+ sb-unix:sigstop
+ sb-unix:sigtstp
+ sb-unix:sigttin
+ sb-unix:sigttou))
:stopped
:signaled)
signal
(sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
sb-unix:TIOCSIGSEND
(sb-sys:int-sap
- (sb-unix:unix-signal-number signal))))
+ signal)))
((:process-group #-hpux :pty-process-group)
(sb-unix:unix-killpg pid signal))
(t
(cond ((not okay)
(values nil errno))
((and (eql pid (process-pid proc))
- (= (sb-unix:unix-signal-number signal)
- (sb-unix:unix-signal-number :sigcont)))
+ (= signal sb-unix:sigcont))
(setf (process-%status proc) :running)
(setf (process-exit-code proc) nil)
(when (process-status-hook proc)
;;; list of handlers installed by RUN-PROGRAM
(defvar *handlers-installed* nil)
-#+FreeBSD
-(define-alien-type nil
- (struct sgttyb
- (sg-ispeed sb-alien:char) ; input speed
- (sg-ospeed sb-alien:char) ; output speed
- (sg-erase sb-alien:char) ; erase character
- (sg-kill sb-alien:char) ; kill character
- (sg-flags sb-alien:short))) ; mode flags
-#+OpenBSD
-(define-alien-type nil
- (struct sgttyb
- (sg-four sb-alien:int)
- (sg-chars (array sb-alien:char 4))
- (sg-flags sb-alien:int)))
-
;;; 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.
sb-unix:o_rdwr
#o666)))
(when slave-fd
- ;; comment from classic CMU CL:
- ;; Maybe put a vhangup here?
- ;;
- ;; FIXME: It seems as though this logic should be in
- ;; OPEN-PTY, not FIND-A-PTY (both from the comments
- ;; documenting DEFUN FIND-A-PTY, and from the
- ;; connotations of the function names).
- ;;
- ;; FIXME: It would be nice to have a note, and/or a pointer
- ;; to some reference material somewhere, explaining
- ;; why we need this on *BSD and not on Linux.
- #+bsd
- (sb-alien:with-alien ((stuff (sb-alien:struct sgttyb)))
- (let ((sap (sb-alien:alien-sap stuff)))
- (sb-unix:unix-ioctl slave-fd sb-unix:TIOCGETP sap)
- (setf (sb-alien:slot stuff 'sg-flags)
- ;; This is EVENP|ODDP, the same numeric code
- ;; both on FreeBSD and on OpenBSD. -- WHN 20000929
- #o300) ; EVENP|ODDP
- (sb-unix:unix-ioctl slave-fd sb-unix:TIOCSETP sap)
- (sb-unix:unix-ioctl master-fd sb-unix:TIOCGETP sap)
- (setf (sb-alien:slot stuff 'sg-flags)
- (logand (sb-alien:slot stuff 'sg-flags)
- ;; This is ~ECHO, the same numeric
- ;; code both on FreeBSD and on OpenBSD.
- ;; -- WHN 20000929
- (lognot 8))) ; ~ECHO
- (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap)))
(return-from find-a-pty
(values master-fd
slave-fd
(values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
(defmacro with-c-strvec ((var str-list) &body body)
- (let ((sap (gensym "SAP-"))
- (size (gensym "SIZE-")))
+ (with-unique-names (sap size)
`(multiple-value-bind
(,sap ,var ,size)
(string-list-to-c-strvec ,str-list)
;;; 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))
+ (setf unix-filename (coerce unix-filename 'base-string))
(values (and (eq (sb-unix:unix-file-kind unix-filename) :file)
(sb-unix:unix-access unix-filename sb-unix:x_ok))))
+(defun find-executable-in-search-path (pathname
+ &optional
+ (search-path (posix-getenv "PATH")))
+ "Find the first executable file matching PATHNAME in any of the colon-separated list of pathnames SEARCH-PATH"
+ (loop for end = (position #\: 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 (merge-pathnames pathname truename))
+ when (and fullpath
+ (unix-filename-is-executable-p (namestring 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
(posix-environ))
environment-p)
(wait t)
+ search
pty
input
if-input-does-not-exist
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
+ a list of SIMPLE-BASE-STRINGs describing the new Unix environment
+ (as in \"man environ\"). The default is to copy the environment of
the current process.
:ENV
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
+ 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.
(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 :sigchld #'sigchld-handler)
+ (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler)
;; Prepend the program to the argument list.
(push (namestring program) args)
(let (;; Clear various specials used by GET-DESCRIPTOR-FOR to
;; 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:"),
- ;; which is the right idea (searching through the Unix
- ;; PATH). Unfortunately, there is no logical pathname
- ;; "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.
- ;; 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))
+ (let ((pfile
+ (if search
+ (let ((p (find-executable-in-search-path program)))
+ (and p (unix-namestring p t)))
+ (unix-namestring program t)))
(cookie (list 0)))
(unless pfile
(error "no such program: ~S" program))
projects / sbcl.git / blobdiff