Skip to content
Snippets Groups Projects
unix.lisp 124 KiB
Newer Older
  (sockaddr (* t))
  (len (* unsigned)))

(def-alien-routine ("getsockname" unix-getsockname) int
  (socket int)
  (sockaddr (* t))
  (len (* unsigned)))

(def-alien-routine ("getsockopt" unix-getsockopt) int
  (socket int)
  (level int)
  (optname int)
  (optval (* t))
  (optlen unsigned :in-out))

(def-alien-routine ("setsockopt" unix-setsockopt) int
  (socket int)
  (level int)
  (optname int)
  (optval (* t))
  (optlen unsigned))

(defun unix-recvfrom (fd buffer length flags sockaddr len)
  (with-alien ((l c-call:int len))
    (values
     (alien-funcall (extern-alien "recvfrom"
				  (function c-call:int
					    c-call:int
					    system-area-pointer
					    c-call:int
					    c-call:int
					    (* t)
					    (* c-call:int)))
		    fd
		    (system:vector-sap buffer)
		    length
		    flags
		    sockaddr
		    (addr l))
     l)))

#-unicode
(def-alien-routine ("sendto" unix-sendto) int
  (fd int)
  (buffer c-string)
  (length int)
  (flags int)
  (sockaddr (* t))
  (len int))

(defun unix-sendto (fd buffer length flags sockaddr len)
  (alien-funcall (extern-alien "sendto"
			       (function c-call:int
					 c-call:int
					 system-area-pointer
					 c-call:int
					 c-call:int
					 (* t)
					 c-call:int))
		 fd
		 (system:vector-sap buffer)
		 length
		 flags
		 sockaddr
		 len))

(def-alien-routine ("shutdown" unix-shutdown) int
  (socket int)
  (level int))


;;;
;;; Support for the Interval Timer (experimental)
;;;


(defconstant ITIMER-REAL 0)
(defconstant ITIMER-VIRTUAL 1)
(defconstant ITIMER-PROF 2)

toy's avatar
toy committed
(defun unix-getitimer (which)
  "Unix-getitimer returns the INTERVAL and VALUE slots of one of
   three system timers (:real :virtual or :profile). On success,
   unix-getitimer returns 5 values,
   T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec."
  (declare (type (member :real :virtual :profile) which)
	   (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 ((itv (struct itimerval)))
      (syscall* ("getitimer" int (* (struct itimerval)))
		(values T
			(slot (slot itv 'it-interval) 'tv-sec)
			(slot (slot itv 'it-interval) 'tv-usec)
			(slot (slot itv 'it-value) 'tv-sec)
			(slot (slot itv 'it-value) 'tv-usec))
		which (alien-sap (addr itv))))))

toy's avatar
toy committed
(defun unix-setitimer (which int-secs int-usec val-secs val-usec)
  " Unix-setitimer sets the INTERVAL and VALUE slots of one of
   three system timers (:real :virtual or :profile). A SIGALRM signal
   will be delivered VALUE <seconds+microseconds> from now. INTERVAL,
   when non-zero, is <seconds+microseconds> to be loaded each time
   the timer expires. Setting INTERVAL and VALUE to zero disables
   the timer. See the Unix man page for more details. On success,
   unix-setitimer returns the old contents of the INTERVAL and VALUE
   slots as in unix-getitimer."
  (declare (type (member :real :virtual :profile) which)
	   (type (unsigned-byte 29) int-secs val-secs)
	   (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)))))))

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))))))))

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)))))))

(def-alien-type nil
  (struct utsname
    (sysname (array char #+svr4 257 #+bsd 256))
    (nodename (array char #+svr4 257 #+bsd 256))
    (release (array char #+svr4 257 #+bsd 256))
    (version (array char #+svr4 257 #+bsd 256))
    (machine (array char #+svr4 257 #+bsd 256))))
rtoy's avatar
rtoy committed

(defun unix-uname ()
  (with-alien ((names (struct utsname)))
    (syscall* (#-freebsd "uname"
	       #+freebsd "__xuname" #+freebsd int
	       (* (struct utsname)))
	      (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))
	      #+freebsd 256
	      (addr names))))
rtoy's avatar
rtoy committed

#+(and solaris svr4)
(export '(unix-sysinfo
	  si-sysname si-hostname si-release si-version si-machine
	  si-architecture si-hw-serial si-hw-provider si-srpc-domain
	  si-platform si-isalist si-dhcp-cache))

#+(and solaris svr4)
(progn
;; 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)
  ;; Hope a buffer of length 2048 is long enough.
  (with-alien ((buf (array c-call:unsigned-char 2048)))
    (let ((result
	   (alien-funcall
	    (extern-alien "sysinfo"
			  (function c-call:int
				    c-call:int
				    c-call:c-string
				    c-call:int))
	    command
	    (cast buf (* c-call:char))
	    2048)))
      (when (>= result 0)
	(cast buf c-call:c-string)))))
rtoy's avatar
rtoy committed

#+solaris
(export '(rlimit_cpu rlimit_fsize rlimit_data rlimit_stack rlimit_core rlimit_nofile
	  rlimit_vmem rlimit_as))

#+solaris
(progn
(defconstant rlimit_cpu 0
  "CPU time per process (in milliseconds)")
(defconstant rlimit_fsize 1
  "Maximum file size")
(defconstant rlimit_data 2
  "Data segment size")
(defconstant rlimit_stack 3
  "Stack size")
(defconstant rlimit_core 4
  "Core file size")
(defconstant rlimit_nofile 5
  "Number of open files")
(defconstant rlimit_vmem 6
  "Maximum mapped memory")
(defconstant rlimit_as rlimit_vmem)
)

#+(and darwin x86)
(export '(rlimit_cpu rlimit_fsize rlimit_data rlimit_stack rlimit_core
	  rlimit_as rlimit_rss rlimit_memlock rlimit_nproc rlimit_nofile))

#+(and darwin x86)
(progn
(defconstant rlimit_cpu 0
  "CPU time per process")
(defconstant rlimit_fsize 1
  "File size")
(defconstant rlimit_data 2
  "Data segment size")
(defconstant rlimit_stack 3
  "Stack size")
(defconstant rlimit_core 4
  "Core file size")
(defconstant rlimit_as 5
  "Addess space (resident set size)")
(defconstant rlimit_rss rlimit_as)
(defconstant rlimit_memlock 6
  "Locked-in-memory address space")
(defconstant rlimit_nproc 7
  "Number of processes")
(defconstant rlimit_nofile 8
  "Number of open files")
)


#+(or solaris (and darwin x86))
(export '(unix-getrlimit))

#+(or solaris (and darwin x86))
(defun unix-getrlimit (resource)
  "Get the limits on the consumption of system resouce specified by
  Resource.  If successful, return three values: T, the current (soft)
  limit, and the maximum (hard) limit."
  
  (with-alien ((rlimit (struct rlimit)))
    (syscall ("getrlimit" c-call:int (* (struct rlimit)))
	     (values t
		     (slot rlimit 'rlim-cur)
		     (slot rlimit 'rlim-max))
	     resource (addr rlimit))))
toy's avatar
toy committed
;; EOF