diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index c0edc81..4d5def3 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -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 diff --git a/scheme/user-group-info.scm b/scheme/user-group-info.scm index ac9fa81..909438d 100644 --- a/scheme/user-group-info.scm +++ b/scheme/user-group-info.scm @@ -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"