scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Parsing of id options, support for id -P 

part of darcs patch Sat Sep 17 18:05:43 EEST 2005  Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
This commit is contained in:
eknauel 2005-09-27 08:46:49 +00:00
parent 7c5cec84b8
commit fbc7cc3929
2 changed files with 68 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
scheme/nuit-packages.scm
View File

@ -10,7 +10,8 @@
(define-interface utils-interface
(export display-to-string
write-to-string))
write-to-string
on/off-option-processor))
(define-structure utils utils-interface
(open scheme
@ -163,7 +164,9 @@
define-record-types
(subset primitives (record-ref record?))
(subset srfi-13 (string-join))
(subset srfi-1 (partition))
srfi-37
dirlist-view-plugin
fs-object
plugin

68
scheme/user-group-info.scm
View File

@ -36,12 +36,64 @@
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)))))
(define (id command args)
;; TODO parse command line arguments
(let* ((maybe-username (if (null? args)
'()
args))
(out (run/string (id ,@ maybe-username)))
(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))
((member 'gid options)
"-g option not supported yet")
((member 'human-readable options)
"-p option not supported yet")
((member 'uid options)
"-u option not supported yet")
(else
"illegal aruments for id" 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
@ -52,6 +104,12 @@
(parse-group-list (match:substring match 5)))
'cannot-parse)))
(define (run-passwd-id maybe-username)
(let* ((out (run/string (id -P ,@ maybe-username))))
out))
(register-plugin!
(make-command-plugin
"id"