Tiny plugin for the "fs la" command from AFS

scheme/afs.scm

@@ -0,0 +1,79 @@
+
+(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?))

scheme/go

@@ -1,5 +1,5 @@
 #!/bin/sh
-args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
+args="-lel afs-0.2/load.scm -lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
 echo "Starting scsh with options: $args" 
 exec scsh $args 
 #-c "(nuit)"

scheme/gogo

@@ -1,3 +1,3 @@
 #!/bin/sh
-args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
+args="-lel afs/load.scm -lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
 exec scsh $args -c "(nuit)"

scheme/nuit-packages.scm

@@ -152,6 +152,20 @@
         tty-debug)
   (files user-group-info))
   
+;;; AFS
+
+
+(define-structure afs-plugin (export)
+  (open scheme-with-scsh
+        afs-fs
+        define-record-types
+        (subset srfi-1 (iota))
+
+        ncurses
+        select-list
+        plugin
+        layout)
+  (files afs))
 
 ;;; file list view plugin
 
@@ -558,6 +572,7 @@
 	joblist-viewer
 	dirlist-view-plugin
         user-group-info-plugin
+        afs-plugin
 	process-viewer
 	standard-command-plugin
 	standard-viewer