500 lines
16 KiB
Scheme
500 lines
16 KiB
Scheme
(define key-return 10)
|
|
|
|
(define-record-type id-output :id-output
|
|
(make-id-output uid name gid group groups)
|
|
id-output?
|
|
(uid id-output-uid)
|
|
(name id-output-name)
|
|
(gid id-output-gid)
|
|
(group id-output-group)
|
|
(groups id-output-groups))
|
|
|
|
(define id-regexp
|
|
(rx
|
|
(: "uid=" (submatch (+ digit))
|
|
"(" (submatch (+ alphabetic))
|
|
") gid=" (submatch (+ digit))
|
|
"(" (submatch (+ alphabetic))
|
|
") groups=" (submatch (* any)))))
|
|
|
|
(define (parse-group-list s)
|
|
(let ((gid-or-gid/name
|
|
(rx (| (submatch (+ digit))
|
|
(: (submatch (+ digit))
|
|
"("
|
|
(submatch (+ alphabetic))
|
|
")")))))
|
|
(regexp-fold
|
|
gid-or-gid/name
|
|
(lambda (start match l)
|
|
(cond ((match:substring match 1)
|
|
=> (lambda (gid)
|
|
(cons gid l)))
|
|
(else
|
|
(cons (cons (match:substring match 2)
|
|
(match:substring match 3))
|
|
l))))
|
|
'() s)))
|
|
|
|
(define (parse-id-arguments args)
|
|
(let ((gids-option
|
|
(option '(#\G) #f #f
|
|
(on/off-option-processor 'gids)))
|
|
(passwd-option
|
|
(option '(#\P) #f #f
|
|
(on/off-option-processor 'passwd)))
|
|
(gid-option
|
|
(option '(#\g) #f #f
|
|
(on/off-option-processor 'gid)))
|
|
(name-instead-option
|
|
(option '(#\n) #f #f
|
|
(on/off-option-processor 'name-instead)))
|
|
(human-readable-option
|
|
(option '(#\p) #f #f
|
|
(on/off-option-processor 'human-readable)))
|
|
(real-option
|
|
(option '(#\r) #f #f
|
|
(on/off-option-processor 'real)))
|
|
(uid-option
|
|
(option '(#\u) #f #f
|
|
(on/off-option-processor 'uid))))
|
|
(let ((given-args
|
|
(args-fold
|
|
args
|
|
(list gids-option passwd-option gid-option
|
|
name-instead-option human-readable-option
|
|
real-option uid-option)
|
|
(lambda (option name args operands)
|
|
(error "Unknown id option" name))
|
|
cons '())))
|
|
(receive (options args) (partition pair? given-args)
|
|
(values (map car options) args)))))
|
|
|
|
;;;usage: id [user]
|
|
;;; id -G [-n] [user]
|
|
;;; id -M
|
|
;;; id -P [user]
|
|
;;; id -g [-nr] [user]
|
|
;;; id -p [user]
|
|
;;; id -u [-nr] [user]
|
|
(define (id command args)
|
|
(receive (options others) (parse-id-arguments args)
|
|
(let ((maybe-username (if (null? others)
|
|
'()
|
|
others))
|
|
(no-options (length options)))
|
|
(cond
|
|
((null? options)
|
|
(run-standard-id maybe-username))
|
|
((and (member 'passwd options)
|
|
(= no-options 1))
|
|
(run-passwd-id maybe-username))
|
|
((and (member 'gid options)
|
|
(null? (lset-difference
|
|
eq?
|
|
options
|
|
'(gid real name-instead))))
|
|
(run-uid/gid-id options args))
|
|
((and (member 'uid options)
|
|
(null? (lset-difference
|
|
eq?
|
|
options
|
|
'(uid real name-instead))))
|
|
(run-uid/gid-id options args))
|
|
((and (member 'human-readable options)
|
|
(= no-options 1))
|
|
(run-human-readable-id maybe-username))
|
|
(else
|
|
(string-append
|
|
"illegal arguments for id " (string-join args)))))))
|
|
|
|
|
|
(define (run-standard-id maybe-username)
|
|
(let* ((out (run/string (id ,@ maybe-username)))
|
|
(match (regexp-search id-regexp out)))
|
|
(if match
|
|
(make-id-output
|
|
(match:substring match 1)
|
|
(match:substring match 2)
|
|
(match:substring match 3)
|
|
(match:substring match 4)
|
|
(parse-group-list (match:substring match 5)))
|
|
'cannot-parse)))
|
|
|
|
(define (run-passwd-id maybe-username)
|
|
(let* ((out (run/string (id -P ,@ maybe-username))))
|
|
out))
|
|
|
|
(define (run-uid/gid-id options args)
|
|
(let ((out (run/strings (id ,@args))))
|
|
(if (member 'name-instead options)
|
|
(car out)
|
|
(string->number (car out)))))
|
|
|
|
(define (run-human-readable-id maybe-username)
|
|
(run/string (id -p ,@ maybe-username)))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin
|
|
"id"
|
|
#f
|
|
id))
|
|
|
|
(define (make-id-output-select-list ido num-lines)
|
|
(make-select-list
|
|
`(,(make-unmarked-text-element
|
|
(cons 'uid
|
|
(string->number
|
|
(id-output-uid ido)))
|
|
#t
|
|
(string-append "UID: " (id-output-uid ido)))
|
|
,(make-unmarked-text-element
|
|
(cons 'user (id-output-name ido))
|
|
#t
|
|
(string-append "Name: " (id-output-name ido)))
|
|
,(make-unmarked-text-element
|
|
(cons 'gid
|
|
(string->number
|
|
(id-output-gid ido)))
|
|
#t
|
|
(string-append "GID: " (id-output-gid ido)))
|
|
,(make-unmarked-text-element
|
|
(cons 'group
|
|
(id-output-group ido))
|
|
#t
|
|
(string-append "GID: " (id-output-group ido)))
|
|
,(make-unmarked-text-element
|
|
'text
|
|
#f
|
|
"Groups:")
|
|
,@(map (lambda (group)
|
|
(let ((gid (if (pair? group)
|
|
(car group)
|
|
group))
|
|
(gname (if (pair? group)
|
|
(cdr group)
|
|
"")))
|
|
(make-unmarked-text-element
|
|
(cons 'gid (string->number gid))
|
|
#t
|
|
(string-append " " gid " " gname))))
|
|
(id-output-groups ido)))
|
|
num-lines))
|
|
|
|
(define (make-id-output-browser ido buffer)
|
|
(let ((ido ido)
|
|
(buffer buffer)
|
|
(selection-list
|
|
(make-id-output-select-list
|
|
ido
|
|
(result-buffer-num-lines buffer))))
|
|
|
|
(define (prepare-selection-for-scheme-mode infos)
|
|
(string-append "'" (write-to-string (map cdr infos))))
|
|
|
|
(define (prepare-selection-for-command-mode infos)
|
|
(string-join
|
|
(map (lambda (type.val)
|
|
(case (car type.val)
|
|
((user group) (cdr type.val))
|
|
((uid gid) (number->string (cdr type.val)))
|
|
(else
|
|
(error "unknown type in prepare-selection-for-command-mode"
|
|
type.val))))
|
|
infos)))
|
|
|
|
(define (get-selection-as-text self for-scheme-mode? focus-object-table)
|
|
(let ((infos
|
|
(select-list-get-selection selection-list)))
|
|
((if for-scheme-mode?
|
|
prepare-selection-for-scheme-mode
|
|
prepare-selection-for-command-mode)
|
|
infos)))
|
|
|
|
(define (get-selection-as-ref self focus-object-table)
|
|
(let ((infos (select-list-get-selection selection-list))
|
|
(make-reference (lambda (obj)
|
|
(make-focus-object-reference
|
|
focus-object-table obj))))
|
|
(string-append
|
|
"(list "
|
|
(string-join
|
|
(map write-to-string
|
|
(map make-reference
|
|
(map cdr infos))))
|
|
")")))
|
|
|
|
(lambda (message)
|
|
(case message
|
|
((paint)
|
|
(lambda (self win buffer have-focus?)
|
|
(paint-selection-list selection-list
|
|
win (result-buffer-num-cols buffer)
|
|
have-focus?)))
|
|
((key-press)
|
|
(lambda (self key control-x-pressed?)
|
|
(cond
|
|
((= key key-return)
|
|
(let ((selected
|
|
(select-list-selected-entry selection-list)))
|
|
(cond
|
|
((and (pair? selected)
|
|
(eq? (car selected) 'user))
|
|
(make-user-info-browser
|
|
(user-info (cdr selected)) buffer))
|
|
((and (pair? selected)
|
|
(eq? (car selected) 'uid))
|
|
(make-user-info-browser
|
|
(user-info (cdr selected)) buffer))
|
|
((and (pair? selected)
|
|
(eq? (car selected) 'group))
|
|
(make-group-info-browser
|
|
(group-info (cdr selected)) buffer))
|
|
((and (pair? selected)
|
|
(eq? (car selected) 'gid))
|
|
(make-group-info-browser
|
|
(group-info (cdr selected)) buffer))
|
|
(else self))))
|
|
(else
|
|
(set! selection-list
|
|
(select-list-handle-key-press
|
|
selection-list key))
|
|
self))))
|
|
((get-selection-as-text)
|
|
get-selection-as-text)
|
|
((get-selection-as-ref)
|
|
get-selection-as-ref)
|
|
(else
|
|
(error "unknown message in make-id-output-browser"
|
|
message))))))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-id-output-browser id-output?))
|
|
|
|
(define (make-gi-select-list gi num-lines)
|
|
(make-select-list
|
|
`(,(make-unmarked-text-element 'name
|
|
#t
|
|
(string-append "Name: " (group-info:name gi)))
|
|
,(make-unmarked-text-element 'gid
|
|
#t
|
|
(string-append "GID: " (number->string (group-info:gid gi))))
|
|
,(make-unmarked-text-element 'text
|
|
#f
|
|
"Members:")
|
|
,@(map (lambda (user)
|
|
(make-unmarked-text-element (cons 'member user)
|
|
#t
|
|
(string-append " " user)))
|
|
(group-info:members gi)))
|
|
num-lines))
|
|
|
|
(define (make-ui-select-list ui num-lines)
|
|
(make-select-list
|
|
(list (make-unmarked-text-element (user-info:name ui)
|
|
#t
|
|
(string-append "Name: " (user-info:name ui)))
|
|
(make-unmarked-text-element 'uid
|
|
#t
|
|
(string-append "UID: "
|
|
(number->string (user-info:uid ui))))
|
|
(make-unmarked-text-element 'gid
|
|
#t
|
|
(string-append "GID: "
|
|
(number->string (user-info:gid ui))))
|
|
(make-unmarked-text-element 'home-dir
|
|
#t
|
|
(string-append "Home: "
|
|
(user-info:home-dir ui)))
|
|
(make-unmarked-text-element 'shell
|
|
#t
|
|
(string-append "Shell: "
|
|
(user-info:shell ui))))
|
|
num-lines))
|
|
|
|
(define (make-group-info-browser gi buffer)
|
|
(let ((gi gi)
|
|
(buffer buffer)
|
|
(selection-list
|
|
(make-gi-select-list gi (result-buffer-num-lines buffer))))
|
|
|
|
(define (group-info-element->value info)
|
|
(case info
|
|
((gid)
|
|
(group-info:gid gi))
|
|
((name)
|
|
(group-info:name gi))
|
|
(else ;members
|
|
(cdr info))))
|
|
|
|
(define (prepare-selection-for-command-mode infos)
|
|
(string-join
|
|
(map display-to-string
|
|
(map group-info-element->value infos))))
|
|
|
|
(define (prepare-selection-for-scheme-mode infos)
|
|
(string-append
|
|
"'"
|
|
(write-to-string
|
|
(map group-info-element->value infos))))
|
|
|
|
(define (get-selection-as-text self for-scheme-mode?
|
|
focus-object-table)
|
|
(let ((infos
|
|
(select-list-get-selection selection-list)))
|
|
((if for-scheme-mode?
|
|
prepare-selection-for-scheme-mode
|
|
prepare-selection-for-command-mode)
|
|
infos)))
|
|
|
|
(define (get-selection-as-ref self focus-object-table)
|
|
(let ((infos
|
|
(select-list-get-selection selection-list))
|
|
(make-reference (lambda (obj)
|
|
(make-focus-object-reference
|
|
focus-object-table obj))))
|
|
(string-append
|
|
"(list "
|
|
(string-join
|
|
(map write-to-string
|
|
(map make-reference
|
|
(map group-info-element->value infos))))
|
|
")")))
|
|
|
|
|
|
(lambda (message)
|
|
(case message
|
|
((paint)
|
|
(lambda (self win buffer have-focus?)
|
|
(paint-selection-list selection-list
|
|
win (result-buffer-num-cols buffer)
|
|
have-focus?)))
|
|
((key-press)
|
|
(lambda (self key control-x-pressed?)
|
|
(cond
|
|
((= key key-return)
|
|
(let ((selected (select-list-selected-entry selection-list)))
|
|
(cond
|
|
((and (pair? selected)
|
|
(eq? (car selected) 'member))
|
|
(make-user-info-browser (user-info (cdr selected)) buffer))
|
|
(else self))))
|
|
(else
|
|
(set! selection-list
|
|
(select-list-handle-key-press
|
|
selection-list key))
|
|
self))))
|
|
((get-selection-as-text)
|
|
get-selection-as-text)
|
|
((get-selection-as-ref)
|
|
get-selection-as-ref)
|
|
(else
|
|
(error "unknown message in make-group-info-browser" message))))))
|
|
|
|
(define (make-user-info-browser ui buffer)
|
|
(let ((ui ui)
|
|
(buffer buffer)
|
|
(selection-list
|
|
(make-ui-select-list ui (result-buffer-num-lines buffer))))
|
|
|
|
(define (user-info-element->value info)
|
|
(case info
|
|
((gid)
|
|
(user-info:gid ui))
|
|
((uid)
|
|
(user-info:uid ui))
|
|
((home-dir)
|
|
(user-info:home-dir ui))
|
|
((shell)
|
|
(user-info:shell ui))
|
|
(else ;user name
|
|
info)))
|
|
|
|
(define (prepare-selection-for-command-mode infos)
|
|
(string-join
|
|
(map display-to-string
|
|
(map user-info-element->value infos))))
|
|
|
|
(define (prepare-selection-for-scheme-mode infos)
|
|
(string-append
|
|
"'"
|
|
(write-to-string
|
|
(map user-info-element->value infos))))
|
|
|
|
(define (get-selection-as-text self for-scheme-mode?
|
|
focus-object-table)
|
|
(let ((infos
|
|
(select-list-get-selection selection-list)))
|
|
((if for-scheme-mode?
|
|
prepare-selection-for-scheme-mode
|
|
prepare-selection-for-command-mode)
|
|
infos)))
|
|
|
|
(define (get-selection-as-ref self focus-object-table)
|
|
(let ((infos
|
|
(select-list-get-selection selection-list))
|
|
(make-reference (lambda (obj)
|
|
(make-focus-object-reference
|
|
focus-object-table obj))))
|
|
(string-append
|
|
"(list "
|
|
(string-join
|
|
(map write-to-string
|
|
(map make-reference
|
|
(map user-info-element->value infos))))
|
|
")")))
|
|
|
|
(lambda (message)
|
|
(case message
|
|
((paint)
|
|
(lambda (self win buffer have-focus?)
|
|
(paint-selection-list selection-list
|
|
win (result-buffer-num-cols buffer)
|
|
have-focus?)))
|
|
((key-press)
|
|
(lambda (self key control-x-pressed?)
|
|
(cond
|
|
((= key key-return)
|
|
(let ((selected (select-list-selected-entry selection-list)))
|
|
(case selected
|
|
((gid)
|
|
(make-group-info-browser (group-info (user-info:gid ui)) buffer))
|
|
((uid)
|
|
self)
|
|
((home-dir)
|
|
(make-browser-for-dir (user-info:home-dir ui) buffer))
|
|
((shell)
|
|
(make-fsobjects-viewer
|
|
(list (file-name->fs-object (user-info:shell ui)))
|
|
buffer))
|
|
(else self))))
|
|
(else
|
|
(set! selection-list
|
|
(select-list-handle-key-press
|
|
selection-list key))
|
|
self))))
|
|
((get-selection-as-text)
|
|
get-selection-as-text)
|
|
((get-selection-as-ref)
|
|
get-selection-as-ref)
|
|
(else
|
|
(error "unknown message in make-user-info-browser" message))))))
|
|
|
|
|
|
;; scsh fails to export user-info? and group-info?...
|
|
(define user-info-type (record-ref (user-info 0) 0))
|
|
(define (user-info? x)
|
|
(and (record? x)
|
|
(eq? (record-ref x 0) user-info-type)))
|
|
|
|
(define group-info-type (record-ref (group-info 0) 0))
|
|
(define (group-info? x)
|
|
(and (record? x)
|
|
(eq? (record-ref x 0) group-info-type)))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-user-info-browser user-info?))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-group-info-browser group-info?))
|