needed by the current implementation of SBCL, and makes
no guarantees of interface stability."
:use ("CL" "SB!ALIEN" "SB!C-CALL" "SB!EXT" "SB!INT" "SB!SYS")
- :export ("D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN"
+ :export (;; wrappers around Unix stuff to give just what Lisp needs
+ "UID-USERNAME"
+
+ ;; stuff with a one-to-one mapping to Unix constructs
+ "D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN"
"DEV-T" "DIRECT" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD"
"F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN"
"FAPPEND" "FASYNC" "FCREAT" "FEXCL" "FIONREAD" "FNDELAY" "FTRUNC"
(defun file-author (file)
#!+sb-doc
- "Return the file author as a string, or nil if the author cannot be
+ "Return the file author as a string, or NIL if the author cannot be
determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
or FILE is a wild pathname."
(if (wild-pathname-p file)
(multiple-value-bind (winp dev ino mode nlink uid)
(sb!unix:unix-stat name)
(declare (ignore dev ino mode nlink))
- (if winp (lookup-login-name uid))))))
+ (and winp (sb!unix:uid-username uid))))))
\f
;;;; DIRECTORY
#'string<
:key #'car))))
\f
-;;;; translating Unix uid's
-;;;;
-;;;; FIXME: should probably move into unix.lisp
-
-(defvar *uid-hash-table* (make-hash-table)
- #!+sb-doc
- "hash table for keeping track of uid's and login names")
-
-(/show0 "filesys.lisp 844")
-
-;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous
-;;; lookups are cached in a hash table since groveling the passwd(s)
-;;; files is somewhat expensive. The table may hold NIL for id's that
-;;; cannot be looked up since this keeps the files from having to be
-;;; searched in their entirety each time this id is translated.
-(defun lookup-login-name (uid)
- (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
- (if foundp
- login-name
- (setf (gethash uid *uid-hash-table*)
- (get-group-or-user-name :user uid)))))
-
-;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group")
-;;; since it is a much smaller file, contains all the local id's, and
-;;; most uses probably involve id's on machines one would login into.
-;;; Then if necessary, we look in "/etc/passwds" ("/etc/groups") which
-;;; is really long and has to be fetched over the net.
-;;;
-;;; The result is a SIMPLE-STRING or NIL.
-;;;
-;;; FIXME: Now that we no longer have lookup-group-name, we no longer need
-;;; the GROUP-OR-USER argument.
-(defun get-group-or-user-name (group-or-user id)
- (declare (type (member :group :user) group-or-user))
- (declare (type index id))
- (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
- (declare (simple-string id-string))
- (multiple-value-bind (file1 file2)
- (ecase group-or-user
- (:group (values "/etc/group" "/etc/groups"))
- (:user (values "/etc/passwd" "/etc/passwd")))
- (or (get-group-or-user-name-aux id-string file1)
- (get-group-or-user-name-aux id-string file2)))))
-
-;;; FIXME: Isn't there now a POSIX routine to parse the passwd file?
-;;; getpwent? getpwuid?
-(defun get-group-or-user-name-aux (id-string passwd-file)
- (with-open-file (stream passwd-file)
- (loop
- (let ((entry (read-line stream nil)))
- (unless entry (return nil))
- (let ((name-end (position #\: (the simple-string entry)
- :test #'char=)))
- (when name-end
- (let ((id-start (position #\: (the simple-string entry)
- :start (1+ name-end) :test #'char=)))
- (when id-start
- (incf id-start)
- (let ((id-end (position #\: (the simple-string entry)
- :start id-start :test #'char=)))
- (when (and id-end
- (string= id-string entry
- :start2 id-start :end2 id-end))
- (return (subseq entry 0 name-end))))))))))))
-\f
(/show0 "filesys.lisp 899")
;;; predicate to order pathnames by; goes by name
(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.
;;; Return the process id of the current process.
(define-alien-routine ("getpid" unix-getpid) int)
-;;; Return the real user-id associated with the current process.
+;;; Return the real user id associated with the current process.
(define-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
;;; failure.
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
+#include <pwd.h>
+
#include "runtime.h"
#include "sbcl.h"
copy_to_stat_wrapper(buf, &real_buf);
return ret;
}
+\f
+/*
+ * getpwuid() stuff
+ */
+
+/* Return a newly-allocated string holding the username for "uid", or
+ * NULL if there's no such user.
+ *
+ * KLUDGE: We also return NULL if malloc() runs out of memory
+ * (returning strdup() result) since it's not clear how to handle that
+ * error better. -- WHN 2001-12-28 */
+char *
+uid_username(int uid)
+{
+ struct passwd *p = getpwuid(uid);
+ if (p) {
+ /* The object *p is a static struct which'll be overwritten by
+ * the next call to getpwuid(), so it'd be unsafe to return
+ * p->pw_name without copying. */
+ return strdup(p->pw_name);
+ } else {
+ return 0;
+ }
+}
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.102"
+"0.pre7.103"
projects / sbcl.git / commitdiff