Newer
Older
(defconstant ITIMER-REAL 0)
(defconstant ITIMER-VIRTUAL 1)
(defconstant ITIMER-PROF 2)
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
"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))))))
(defun unix-setitimer (which int-secs int-usec val-secs val-usec)
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
" 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))))))
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
;;;; 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 darwin)
(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)
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
: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 darwin)
(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"))
#+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+))
(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+)))
(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))))))))
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
(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+))
(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))
#.+sc-getgr-r-size-max+)))
(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))))))))
(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 ()
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
#+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)))))))
;; From sys/utsname.h
#+(or solaris darwin freebsd netbsd)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +sys-namelen+
#+solaris 257
#+freebsd 32
#+netbsd 256))
#+(or solaris darwin freebsd netbsd)
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
(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))))))
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
#+(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)))))
)