120 lines
3.1 KiB
Scheme
120 lines
3.1 KiB
Scheme
;;; User info
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-record user-info
|
|
name uid gid home-dir shell
|
|
|
|
;; Make user-info records print like #{user-info shivers}.
|
|
((disclose ui)
|
|
(list "user-info" (user-info:name ui))))
|
|
|
|
|
|
(import-os-error-syscall
|
|
%uid->user-info
|
|
(uid user-info-record)
|
|
"user_info_uid")
|
|
|
|
(import-os-error-syscall
|
|
%name->user-info
|
|
(name user-info-record)
|
|
"user_info_name")
|
|
|
|
(define (uid->user-info uid)
|
|
(let ((empty-user-info (make-user-info #f uid #f #f #f)))
|
|
(if (%uid->user-info uid empty-user-info)
|
|
empty-user-info
|
|
(error "Cannot get user's information" uid->user-info uid))))
|
|
|
|
|
|
(define (name->user-info name)
|
|
(let ((empty-user-info (make-user-info name #f #f #f #f)))
|
|
(if (%name->user-info name empty-user-info)
|
|
empty-user-info
|
|
(error "Cannot get user's information" name->user-info name))))
|
|
|
|
(define (user-info uid/name)
|
|
((cond ((string? uid/name) name->user-info)
|
|
((integer? uid/name) uid->user-info)
|
|
(else (error "user-info arg must be string or integer" uid/name)))
|
|
uid/name))
|
|
|
|
;;; Derived functions
|
|
|
|
(define (->uid uid/name)
|
|
(user-info:uid (user-info uid/name)))
|
|
|
|
(define (->username uid/name)
|
|
(user-info:name (user-info uid/name)))
|
|
|
|
(define (%homedir uid/name)
|
|
(user-info:home-dir (user-info uid/name)))
|
|
|
|
(define home-directory "")
|
|
|
|
(define (init-home-directory home)
|
|
(set! home-directory home))
|
|
|
|
(define (home-dir . maybe-user)
|
|
(if (pair? maybe-user)
|
|
(let ((user (car maybe-user)))
|
|
(ensure-file-name-is-nondirectory
|
|
(or (%homedir user)
|
|
(error "Cannot get user's home directory"
|
|
user))))
|
|
home-directory))
|
|
|
|
;;; (home-file [user] fname)
|
|
|
|
(define (home-file arg1 . maybe-arg2)
|
|
(receive (dir fname)
|
|
(if (pair? maybe-arg2)
|
|
(values (home-dir arg1) (car maybe-arg2))
|
|
(values home-directory arg1))
|
|
(string-append (file-name-as-directory dir) fname)))
|
|
|
|
;;; Group info
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-record group-info
|
|
name gid members
|
|
|
|
;; Make group-info records print like #{group-info wheel}.
|
|
((disclose gi) (list "group-info" (group-info:name gi))))
|
|
|
|
(import-os-error-syscall
|
|
%gid->group-info
|
|
(gid group-info-record)
|
|
"group_info_gid")
|
|
|
|
(import-os-error-syscall
|
|
%name->group-info
|
|
(name group-info-record)
|
|
"group_info_name")
|
|
|
|
(define (gid->group-info gid)
|
|
(let ((empty-group-info (make-group-info #f gid #f)))
|
|
(if (%gid->group-info gid empty-group-info)
|
|
empty-group-info
|
|
(error "Cannot get group's information for gid" gid))))
|
|
|
|
(define (name->group-info name)
|
|
(let ((empty-group-info (make-group-info name #f #f)))
|
|
(if (%name->group-info name empty-group-info)
|
|
empty-group-info
|
|
(error "Cannot get group's information for name" name))))
|
|
|
|
(define (group-info gid/name)
|
|
((cond ((string? gid/name) name->group-info)
|
|
((integer? gid/name) gid->group-info)
|
|
(else (error "group-info arg must be string or integer" gid/name)))
|
|
gid/name))
|
|
|
|
;;; Derived functions
|
|
|
|
(define (->gid name)
|
|
(group-info:gid (group-info name)))
|
|
|
|
(define (->groupname gid)
|
|
(group-info:name (group-info gid)))
|
|
|