Skip to content
Snippets Groups Projects
unix.lisp 117 KiB
Newer Older
	   (type (integer 0 (1000000)) int-usec val-usec)
	   (values t
		   (unsigned-byte 29)(mod 1000000)
		   (unsigned-byte 29)(mod 1000000)))
  (let ((which (ecase which
		 (:real ITIMER-REAL)
		 (:virtual ITIMER-VIRTUAL)
		 (:profile ITIMER-PROF))))
    (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)))))))

#+(or FreeBSD NetBSD)
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)
       :change (slot result 'pw-change)
       :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)))))))

#+(or FreeBSD NetBSD)
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
(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 2048))
	       (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))
	    2048)))
      (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)
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 2048))
	       (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))
	    gid
	    (addr group-info)
	    (cast buf (* c-call:char))
	    2048)))
      (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)
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))
	 :shell (string (cast (slot result 'pw-shell) c-call:c-string)))))))  
toy's avatar
toy committed
;; EOF