\f
;;;; hacking the Unix environment
-(def-alien-routine ("getenv" posix-getenv) c-string
+(define-alien-routine ("getenv" posix-getenv) c-string
"Return the \"value\" part of the environment string \"name=value\" which
corresponds to NAME, or NIL if there is none."
(name c-string))
;;; is not extreme enough, since it doesn't need to be blindingly
;;; fast: we can just implement those functions in C as a wrapper
;;; layer.
-(def-alien-type fd-mask unsigned-long)
+(define-alien-type fd-mask unsigned-long)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant fd-setsize 1024))
-(def-alien-type nil
+(define-alien-type nil
(struct fd-set
(fds-bits (array fd-mask #.(/ fd-setsize 32)))))
;; A time value that is accurate to the nearest
;; microsecond but also has a range of years.
-(def-alien-type nil
+(define-alien-type nil
(struct timeval
(tv-sec time-t) ; seconds
(tv-usec time-t))) ; and microseconds
(defconstant rusage_children -1) ; terminated child processes
(defconstant rusage_both -2)
-(def-alien-type nil
+(define-alien-type nil
(struct rusage
(ru-utime (struct timeval)) ; user time used
(ru-stime (struct timeval)) ; system time used.
(type unix-file-mode mode))
(void-syscall ("mkdir" c-string int) name mode))
+;;; Given a C char* pointer allocated by malloc(), free it and return a
+;;; corresponding Lisp string (or return NIL if the pointer is a C NULL).
+(defun newcharstar-string (newcharstar)
+ (declare (type (alien (* char)) newcharstar))
+ (if (null-alien newcharstar)
+ nil
+ (prog1
+ (cast newcharstar c-string)
+ (free-alien newcharstar))))
+
;;; Return the Unix current directory as a SIMPLE-STRING, in the
;;; style returned by getcwd() (no trailing slash character).
(defun posix-getcwd ()
;; pointer is used. On a system which doesn't support that
;; extension, it'll have to be rewritten somehow.
#!-(or linux openbsd freebsd) (,stub,)
- (let* ((raw-char-ptr (alien-funcall (extern-alien "getcwd"
- (function (* char)
- (* char) size-t))
- nil 0)))
- (if (null-alien raw-char-ptr)
- (simple-perror "getcwd")
- (prog1
- (cast raw-char-ptr c-string)
- (free-alien raw-char-ptr)))))
+ (or (newcharstar-string (alien-funcall (extern-alien "getcwd"
+ (function (* char)
+ (* char)
+ size-t))
+ nil 0))
+ (simple-perror "getcwd")))
;;; Return the Unix current directory as a SIMPLE-STRING terminated
;;; by a slash character.
(void-syscall ("exit" int) code))
;;; Return the process id of the current process.
-(def-alien-routine ("getpid" unix-getpid) int)
+(define-alien-routine ("getpid" unix-getpid) int)
+
+;;; Return the real user id associated with the current process.
+(define-alien-routine ("getuid" unix-getuid) int)
-;;; Return the real user-id associated with the current process.
-(def-alien-routine ("getuid" unix-getuid) int)
+;;; Translate a user id into a login name.
+(defun uid-username (uid)
+ (or (newcharstar-string (alien-funcall (extern-alien "uid_username"
+ (function (* char) int))
+ uid))
+ (error "found no match for Unix uid=~S" uid)))
;;; Invoke readlink(2) on the file name specified by PATH. Return
;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on
(declare (type unix-pathname name))
(void-syscall ("unlink" c-string) name))
-;;; Set the tty-process-group for the unix file-descriptor FD to PGRP.
-;;; If not supplied, FD defaults to "/dev/tty".
-(defun %set-tty-process-group (pgrp &optional fd)
- (let ((old-sigs (unix-sigblock (sigmask :sigttou
- :sigttin
- :sigtstp
- :sigchld))))
- (declare (type (unsigned-byte 32) old-sigs))
- (unwind-protect
- (if fd
- (tcsetpgrp fd pgrp)
- (multiple-value-bind (tty-fd errno) (unix-open "/dev/tty" o_rdwr 0)
- (cond (tty-fd
- (multiple-value-prog1
- (tcsetpgrp tty-fd pgrp)
- (unix-close tty-fd)))
- (t
- (values nil errno)))))
- (unix-sigsetmask old-sigs))))
-
;;; Return the name of the host machine as a string.
(defun unix-gethostname ()
(with-alien ((buf (array char 256)))
;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
;;;
-;;; Like getrusage(2), but return only the system and user time,
-;;; and return the seconds and microseconds as separate values.
+;;; This is like getrusage(2), except it returns only the system and
+;;; user time, and returns the seconds and microseconds as separate
+;;; values.
#!-sb-fluid (declaim (inline unix-fast-getrusage))
(defun unix-fast-getrusage (who)
(declare (values (member t)
\f
;;;; sys/select.h
-(defmacro unix-fast-select (num-descriptors
- read-fds write-fds exception-fds
- timeout-secs &optional (timeout-usecs 0))
- #!+sb-doc
- "Perform the UNIX select(2) system call."
- (declare (type (integer 0 #.FD-SETSIZE) num-descriptors)
+;;;; FIXME: Why have both UNIX-SELECT and UNIX-FAST-SELECT?
+
+;;; Perform the UNIX select(2) system call.
+(declaim (inline unix-fast-select)) ; (used to be a macro in CMU CL)
+(defun unix-fast-select (num-descriptors
+ read-fds write-fds exception-fds
+ timeout-secs &optional (timeout-usecs 0))
+ (declare (type (integer 0 #.fd-setsize) num-descriptors)
(type (or (alien (* (struct fd-set))) null)
read-fds write-fds exception-fds)
(type (or null (unsigned-byte 31)) timeout-secs)
- (type (unsigned-byte 31) timeout-usecs) )
+ (type (unsigned-byte 31) timeout-usecs))
;; FIXME: CMU CL had
- ;; (optimize (speed 3) (safety 0) (inhibit-warnings 3))
- ;; in the declarations above. If they're important, they should
- ;; be in a declaration inside the LET expansion, not in the
- ;; macro compile-time code.
- `(let ((timeout-secs ,timeout-secs))
- (with-alien ((tv (struct timeval)))
- (when timeout-secs
- (setf (slot tv 'tv-sec) timeout-secs)
- (setf (slot tv 'tv-usec) ,timeout-usecs))
- (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
- (* (struct fd-set)) (* (struct timeval)))
- ,num-descriptors ,read-fds ,write-fds ,exception-fds
- (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))))
+ ;; (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
+ ;; here. Is that important for SBCL? If so, why? Profiling might tell us..
+ (with-alien ((tv (struct timeval)))
+ (when timeout-secs
+ (setf (slot tv 'tv-sec) timeout-secs)
+ (setf (slot tv 'tv-usec) timeout-usecs))
+ (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
+ (* (struct fd-set)) (* (struct timeval)))
+ num-descriptors read-fds write-fds exception-fds
+ (if timeout-secs (alien-sap (addr tv)) (int-sap 0)))))
;;; UNIX-SELECT accepts sets of file descriptors and waits for an event
;;; to happen on one of them or to time out.
;;; st_size is a long, not an off-t, because off-t is a 64-bit
;;; quantity on Alpha. And FIXME: "No one would want a file length
;;; longer than 32 bits anyway, right?":-|
-(def-alien-type nil
+(define-alien-type nil
(struct wrapped_stat
(st-dev unsigned-long) ; would be dev-t in a real stat
(st-ino ino-t)
;; the POSIX.4 structure for a time value. This is like a "struct
;; timeval" but has nanoseconds instead of microseconds.
-(def-alien-type nil
+(define-alien-type nil
(struct timespec
(tv-sec long) ; seconds
(tv-nsec long))) ; nanoseconds
;; used by other time functions
-(def-alien-type nil
+(define-alien-type nil
(struct tm
(tm-sec int) ; Seconds. [0-60] (1 leap second)
(tm-min int) ; Minutes. [0-59]
(tm-gmtoff long) ; Seconds east of UTC.
(tm-zone c-string))) ; Timezone abbreviation.
-(def-alien-routine get-timezone sb!c-call:void
- (when sb!c-call:long :in)
- (minutes-west sb!c-call:int :out)
+(define-alien-routine get-timezone sb!alien:void
+ (when sb!alien:long :in)
+ (minutes-west sb!alien:int :out)
(daylight-savings-p sb!alien:boolean :out))
(defun unix-get-minutes-west (secs)
;;; Structure crudely representing a timezone. KLUDGE: This is
;;; obsolete and should never be used.
-(def-alien-type nil
+(define-alien-type nil
(struct timezone
(tz-minuteswest int) ; minutes west of Greenwich
(tz-dsttime int))) ; type of dst correction
(defun unix-resolve-links (pathname)
(declare (type simple-string pathname))
(aver (not (relative-unix-pathname? pathname)))
- (/show "entering UNIX-RESOLVE-LINKS")
+ (/noshow "entering UNIX-RESOLVE-LINKS")
(loop with previous-pathnames = nil do
- (/show pathname previous-pathnames)
+ (/noshow pathname previous-pathnames)
(let ((link (unix-readlink pathname)))
- (/show link)
+ (/noshow link)
;; Unlike the old CMU CL code, we handle a broken symlink by
;; returning the link itself. That way, CL:TRUENAME on a
;; broken link returns the link itself, so that CL:DIRECTORY
pathname
:from-end t)))
(dir (subseq pathname 0 dir-len)))
- (/show dir)
+ (/noshow dir)
(concatenate 'string dir link))
link))))
(if (unix-file-kind new-pathname)
projects / sbcl.git / blobdiff