commander-s/scheme/user-group-info.scm

(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)))))


(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))
       ((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
         (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))
         
         

(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 . args)
           (apply paint-selection-list
                  selection-list args)))
        ((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 . args)
           (apply paint-selection-list
                  selection-list args)))
        ((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 . args)
           (apply paint-selection-list
                  selection-list args)))
        ((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?))