;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not
;;;; visible at GENESIS time.
-(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*)
-
+(define-alien-routine wrapped-environ (* c-string))
(defun posix-environ ()
"Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs."
- (c-strings->string-list environ))
+ (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.
-(sb-alien:define-alien-routine ("wait3" c-wait3) sb-alien:int
+(define-alien-routine ("wait3" c-wait3) sb-alien:int
(status sb-alien:int :out)
(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)))
#-hpux
;;; Find the current foreground process group id.
(defun find-current-foreground-process (proc)
- (sb-alien:with-alien ((result sb-alien:int))
+ (with-alien ((result sb-alien:int))
(multiple-value-bind
(wonp error)
(sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
sb-unix:TIOCGPGRP
- (sb-alien:alien-sap (sb-alien:addr result)))
+ (alien-sap (sb-alien:addr result)))
(unless wonp
(error "TIOCPGRP ioctl failed: ~S" (strerror error)))
result))
;;; 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)
(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
+ for fullpath = (merge-pathnames
+ pathname (truename
+ (subseq search-path start end)))
+ when (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.
;; 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