79 lines
2.1 KiB
Scheme
79 lines
2.1 KiB
Scheme
|
|
||
|
|
(define-record-type acl :acl
|
||
|
|
(make-acl dir afs-perms)
|
||
|
|
acl?
|
||
|
|
(dir acl-dir)
|
||
|
|
(afs-perms acl-afs-perms))
|
||
|
|
|
||
|
|
|
||
|
|
(define (make-header width dir)
|
||
|
|
(list
|
||
|
|
(string-append "Access list for " dir " is")))
|
||
|
|
|
||
|
|
(define (layout-afs-perm width p)
|
||
|
|
(cut-to-size
|
||
|
|
width
|
||
|
|
(string-append
|
||
|
|
(fill-up-string 20 (car p))
|
||
|
|
" "
|
||
|
|
(afs-permissions->string (cdr p)))))
|
||
|
|
|
||
|
|
(define (make-afs-perms-select-list num-cols num-lines afs-perms)
|
||
|
|
(make-select-list
|
||
|
|
(map
|
||
|
|
(lambda (p)
|
||
|
|
(make-unmarked-element p #t (layout-afs-perm num-cols p)))
|
||
|
|
afs-perms)
|
||
|
|
num-lines))
|
||
|
|
|
||
|
|
|
||
|
|
(define (make-acl-viewer acl buffer)
|
||
|
|
(let* ((dir (acl-dir acl))
|
||
|
|
(afs-perms (acl-afs-perms acl))
|
||
|
|
(header (make-header (result-buffer-num-cols buffer) dir))
|
||
|
|
(select-list
|
||
|
|
(make-afs-perms-select-list
|
||
|
|
(result-buffer-num-cols buffer)
|
||
|
|
(- (result-buffer-num-lines buffer) (length header))
|
||
|
|
afs-perms)))
|
||
|
|
(lambda (message)
|
||
|
|
(case message
|
||
|
|
|
||
|
|
((paint)
|
||
|
|
(lambda (self win buffer have-focus?)
|
||
|
|
(let ((hdr-len (length header)))
|
||
|
|
(for-each (lambda (text y)
|
||
|
|
(mvwaddstr win y 0 text))
|
||
|
|
header
|
||
|
|
(iota hdr-len))
|
||
|
|
(paint-selection-list-at
|
||
|
|
select-list 0 hdr-len win buffer have-focus?))))
|
||
|
|
|
||
|
|
((key-press)
|
||
|
|
(lambda (self key control-x-pressed?)
|
||
|
|
(set! select-list
|
||
|
|
(select-list-handle-key-press select-list key))
|
||
|
|
self))
|
||
|
|
|
||
|
|
; ((get-selection) get-selection)
|
||
|
|
|
||
|
|
; ((get-focus-object) get-focus-object)
|
||
|
|
|
||
|
|
(else
|
||
|
|
(error "acl viewer unknown message" message))))))
|
||
|
|
|
||
|
|
(register-plugin!
|
||
|
|
(make-command-plugin "fs"
|
||
|
|
(lambda args #f)
|
||
|
|
(lambda (command args)
|
||
|
|
(cond
|
||
|
|
((or (string=? (car args) "la")
|
||
|
|
(string=? (car args) "listacl"))
|
||
|
|
(make-acl (cadr args)
|
||
|
|
(get-acl (cadr args))))
|
||
|
|
(else
|
||
|
|
(display "unsupported fs command" (car args)))))))
|
||
|
|
|
||
|
|
|
||
|
|
(register-plugin!
|
||
|
|
(make-view-plugin make-acl-viewer acl?))
|