Skip to content
Snippets Groups Projects
unix.lisp 118 KiB
Newer Older
    (with-alien ((itvn (struct itimerval))
		 (itvo (struct itimerval)))
      (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
	    (slot (slot itvn 'it-interval) 'tv-usec) int-usec
	    (slot (slot itvn 'it-value   ) 'tv-sec ) val-secs
	    (slot (slot itvn 'it-value   ) 'tv-usec) val-usec)
      (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
		(values T
			(slot (slot itvo 'it-interval) 'tv-sec)
			(slot (slot itvo 'it-interval) 'tv-usec)
			(slot (slot itvo 'it-value) 'tv-sec)
			(slot (slot itvo 'it-value) 'tv-usec))
		which (alien-sap (addr itvn))(alien-sap (addr itvo))))))

toy's avatar
toy committed

;;;; User and group database access, POSIX Standard 9.2.2

#+solaris
(defun unix-getpwnam (login)
  "Return a USER-INFO structure for the user identified by LOGIN, or NIL if not found."
  (declare (type simple-string login))
  (with-alien ((buf (array c-call:char 1024))
	       (user-info (struct passwd)))
    (let ((result
	   (alien-funcall
	    (extern-alien "getpwnam_r"
			  (function (* (struct passwd))
				    c-call:c-string
				    (* (struct passwd))
				    (* c-call:char)
				    c-call:unsigned-int))
	    login
	    (addr user-info)
	    (cast buf (* c-call:char))
	    1024)))
      (when (not (zerop (sap-int (alien-sap result))))
	(make-user-info
	 :name (string (cast (slot result 'pw-name) c-call:c-string))
	 :password (string (cast (slot result 'pw-passwd) c-call:c-string))
	 :uid (slot result 'pw-uid)
	 :gid (slot result 'pw-gid)
	 :age (string (cast (slot result 'pw-age) c-call:c-string))
	 :comment (string (cast (slot result 'pw-comment) c-call:c-string))
	 :gecos (string (cast (slot result 'pw-gecos) c-call:c-string))
	 :dir (string (cast (slot result 'pw-dir) c-call:c-string))
	 :shell (string (cast (slot result 'pw-shell) c-call:c-string)))))))

cshapiro's avatar
cshapiro committed
#+bsd
toy's avatar
toy committed
(defun unix-getpwnam (login)
  "Return a USER-INFO structure for the user identified by LOGIN, or NIL if not found."
  (declare (type simple-string login))
  (let ((result
         (alien-funcall
          (extern-alien "getpwnam"
                        (function (* (struct passwd))
                                  c-call:c-string))
          login)))
    (when (not (zerop (sap-int (alien-sap result))))
      (make-user-info
       :name (string (cast (slot result 'pw-name) c-call:c-string))
       :password (string (cast (slot result 'pw-passwd) c-call:c-string))
       :uid (slot result 'pw-uid)
       :gid (slot result 'pw-gid)
       #-darwin :change #-darwin (slot result 'pw-change)
toy's avatar
toy committed
       :gecos (string (cast (slot result 'pw-gecos) c-call:c-string))
       :dir (string (cast (slot result 'pw-dir) c-call:c-string))
       :shell (string (cast (slot result 'pw-shell) c-call:c-string))))))

#+solaris
(defun unix-getpwuid (uid)
  "Return a USER-INFO structure for the user identified by UID, or NIL if not found."
  (declare (type unix-uid uid))
  (with-alien ((buf (array c-call:char 1024))
	       (user-info (struct passwd)))
    (let ((result
	   (alien-funcall
	    (extern-alien "getpwuid_r"
			  (function (* (struct passwd))
				    c-call:unsigned-int
				    (* (struct passwd))
				    (* c-call:char)
				    c-call:unsigned-int))
	    uid
	    (addr user-info)
	    (cast buf (* c-call:char))
	    1024)))
      (when (not (zerop (sap-int (alien-sap result))))
	(make-user-info
	 :name (string (cast (slot result 'pw-name) c-call:c-string))
	 :password (string (cast (slot result 'pw-passwd) c-call:c-string))
	 :uid (slot result 'pw-uid)
	 :gid (slot result 'pw-gid)
	 :age (string (cast (slot result 'pw-age) c-call:c-string))
	 :comment (string (cast (slot result 'pw-comment) c-call:c-string))
	 :gecos (string (cast (slot result 'pw-gecos) c-call:c-string))
	 :dir (string (cast (slot result 'pw-dir) c-call:c-string))
	 :shell (string (cast (slot result 'pw-shell) c-call:c-string)))))))

toy's avatar
toy committed
(defun unix-getpwuid (uid)
  "Return a USER-INFO structure for the user identified by UID, or NIL if not found."
  (declare (type unix-uid uid))
  (let ((result
         (alien-funcall
          (extern-alien "getpwuid"
			  (function (* (struct passwd))
				    c-call:unsigned-int))
          uid)))
    (when (not (zerop (sap-int (alien-sap result))))
      (make-user-info
       :name (string (cast (slot result 'pw-name) c-call:c-string))
       :password (string (cast (slot result 'pw-passwd) c-call:c-string))
       :uid (slot result 'pw-uid)
       :gid (slot result 'pw-gid)
       :gecos (string (cast (slot result 'pw-gecos) c-call:c-string))
       :dir (string (cast (slot result 'pw-dir) c-call:c-string))
       :shell (string (cast (slot result 'pw-shell) c-call:c-string))))))

#+solaris
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; sysconf(_SC_GETGR_R_SIZE_MAX)
  (defconstant +sc-getgr-r-size-max+ 7296
    "The maximum size of the group entry buffer"))

toy's avatar
toy committed
#+solaris
(defun unix-getgrnam (name)
  "Return a GROUP-INFO structure for the group identified by NAME, or NIL if not found."
  (declare (type simple-string name))
  (with-alien ((buf (array c-call:char #.+sc-getgr-r-size-max+))
toy's avatar
toy committed
	       (group-info (struct group)))
    (let ((result
	   (alien-funcall
	    (extern-alien "getgrnam_r"
			  (function (* (struct group))
                                    c-call:c-string
                                    (* (struct group))
                                    (* c-call:char)
                                    c-call:unsigned-int))
	    name
	    (addr group-info)
	    (cast buf (* c-call:char))
	    #.+sc-getgr-r-size-max+)))
toy's avatar
toy committed
      (unless (zerop (sap-int (alien-sap result)))
	(make-group-info
	 :name (string (cast (slot result 'gr-name) c-call:c-string))
	 :password (string (cast (slot result 'gr-passwd) c-call:c-string))
	 :gid (slot result 'gr-gid)
         :members (loop :with members = (slot result 'gr-mem)
                        :for i :from 0
                        :for member = (deref members i)
                        :until (zerop (sap-int (alien-sap member)))
                        :collect (string (cast member c-call:c-string))))))))

#+(or FreeBSD NetBSD (and ppc darwin))
toy's avatar
toy committed
(defun unix-getgrnam (name)
  "Return a GROUP-INFO structure for the group identified by NAME, or NIL if not found."
  (declare (type simple-string name))
  (let ((result
         (alien-funcall
          (extern-alien "getgrnam"
                        (function (* (struct group))
                                  c-call:c-string))
          name)))
    (unless (zerop (sap-int (alien-sap result)))
      (make-group-info
       :name (string (cast (slot result 'gr-name) c-call:c-string))
       :password (string (cast (slot result 'gr-passwd) c-call:c-string))
       :gid (slot result 'gr-gid)
       :members (loop :with members = (slot result 'gr-mem)
                      :for i :from 0
                      :for member = (deref members i)
                      :until (zerop (sap-int (alien-sap member)))
                      :collect (string (cast member c-call:c-string)))))))

#+solaris
(defun unix-getgrgid (gid)
  "Return a GROUP-INFO structure for the group identified by GID, or NIL if not found."
  (declare (type unix-gid gid))
  (with-alien ((buf (array c-call:char #.+sc-getgr-r-size-max+))
toy's avatar
toy committed
	       (group-info (struct group)))
    (let ((result
	   (alien-funcall
	    (extern-alien "getgrgid_r"
			  (function (* (struct group))
				     c-call:unsigned-int
				     (* (struct group))
				     (* c-call:char)
				     c-call:unsigned-int))
toy's avatar
toy committed
	    gid
	    (addr group-info)
	    (cast buf (* c-call:char))
	    #.+sc-getgr-r-size-max+)))
toy's avatar
toy committed
      (unless (zerop (sap-int (alien-sap result)))
	(make-group-info
	 :name (string (cast (slot result 'gr-name) c-call:c-string))
	 :password (string (cast (slot result 'gr-passwd) c-call:c-string))
	 :gid (slot result 'gr-gid)
	 :members (loop :with members = (slot result 'gr-mem)
		        :for i :from 0
		        :for member = (deref members i)
		        :until (zerop (sap-int (alien-sap member)))
		        :collect (string (cast member c-call:c-string))))))))
toy's avatar
toy committed

cshapiro's avatar
cshapiro committed
#+bsd
toy's avatar
toy committed
(defun unix-getgrgid (gid)
  "Return a GROUP-INFO structure for the group identified by GID, or NIL if not found."
  (declare (type unix-gid gid))
  (let ((result
         (alien-funcall
          (extern-alien "getgrgid"
                        (function (* (struct group))
                                  c-call:unsigned-int))
          gid)))
    (unless (zerop (sap-int (alien-sap result)))
      (make-group-info
       :name (string (cast (slot result 'gr-name) c-call:c-string))
       :password (string (cast (slot result 'gr-passwd) c-call:c-string))
       :gid (slot result 'gr-gid)
       :members (loop :with members = (slot result 'gr-mem)
                      :for i :from 0
                      :for member = (deref members i)
                      :until (zerop (sap-int (alien-sap member)))
                      :collect (string (cast member c-call:c-string)))))))

#+solaris
(defun unix-setpwent ()
  (void-syscall ("setpwent")))

#+solaris
(defun unix-endpwent ()
emarsden's avatar
 
emarsden committed
  (void-syscall ("endpwent")))

#+solaris
(defun unix-getpwent ()
  (with-alien ((buf (array c-call:char 1024))
	       (user-info (struct passwd)))
    (let ((result
	   (alien-funcall
	    (extern-alien "getpwent_r"
			  (function (* (struct passwd))
				    (* (struct passwd))
				    (* c-call:char)
				    c-call:unsigned-int))
	    (addr user-info)
	    (cast buf (* c-call:char))
	    1024)))
      (when (not (zerop (sap-int (alien-sap result))))
	(make-user-info
	 :name (string (cast (slot result 'pw-name) c-call:c-string))
	 :password (string (cast (slot result 'pw-passwd) c-call:c-string))
	 :uid (slot result 'pw-uid)
	 :gid (slot result 'pw-gid)
	 :age (string (cast (slot result 'pw-age) c-call:c-string))
	 :comment (string (cast (slot result 'pw-comment) c-call:c-string))
	 :gecos (string (cast (slot result 'pw-gecos) c-call:c-string))
	 :dir (string (cast (slot result 'pw-dir) c-call:c-string))
rtoy's avatar
rtoy committed
	 :shell (string (cast (slot result 'pw-shell) c-call:c-string)))))))

;; From sys/utsname.h
cshapiro's avatar
cshapiro committed
#+(or solaris bsd)
rtoy's avatar
rtoy committed
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +sys-namelen+
    #+solaris 257
cshapiro's avatar
cshapiro committed
    #+bsd 256))
rtoy's avatar
rtoy committed

cshapiro's avatar
cshapiro committed
#+(or solaris bsd)
rtoy's avatar
rtoy committed
(progn
rtoy's avatar
rtoy committed
(def-alien-type nil
    (struct utsname
	    (sysname (array char #.+sys-namelen+))
	    (nodename (array char #.+sys-namelen+))
	    (release (array char #.+sys-namelen+))
	    (version (array char #.+sys-namelen+))
	    (machine (array char #.+sys-namelen+))))


(defun unix-uname ()
  (with-alien ((names (struct utsname)))
    (let ((result
	   (alien-funcall
	    (extern-alien "uname"
			  (function int
				    (* (struct utsname))))
	    (addr names))))
      (when (>= result 0)
	(values (cast (slot names 'sysname) c-string)
		(cast (slot names 'nodename) c-string)
		(cast (slot names 'release) c-string)
		(cast (slot names 'version) c-string)
		(cast (slot names 'machine) c-string))))))
rtoy's avatar
rtoy committed
)
rtoy's avatar
rtoy committed

#+(and solaris svr4)
(progn
(def-alien-routine sysinfo long
  (command int)
  (buf c-string)
  (count long))

;; From sys/systeminfo.h.  We don't list the set values here.
(def-enum + 1
  si-sysname si-hostname si-release si-version si-machine
  si-architecture si-hw-serial si-hw-provider si-srpc-domain)

(def-enum + 513
  si-platform si-isalist si-dhcp-cache)

(defun unix-sysinfo (command)
  (let* ((count 2048)			; Hope this is long enough!
	 (buf (make-string count))
	 (result (sysinfo command buf count)))
    (when (>= result 0)
      (subseq buf 0 (1- result)))))
)

toy's avatar
toy committed
;; EOF