Added a README, an installation script, and various small fixes.

README

@@ -0,0 +1,92 @@
+Commander S 0.0 README					-*- outline -*-
+
+
+                                                   Tuebingen, June 2005
+
+
+			     Commander S
+                             ===========
+
+* Requirements
+
+  Before installing Commander S, you need to install the following
+  software:
+
+  - The current CVS version of scsh, the Scheme Shell.  The latest
+    release, version 0.6.6, contains two small bugs that prevent
+    Commander S from running correctly. Alternativly, you may apply
+    the patches listed in the last section of this README to your scsh
+    0.6.6 source tree.
+    (From <http://www.scsh.net>)
+
+  - Version 1.1.0 of install-lib, the scsh installation library
+    (From <http://lamp.epfl.ch/~schinz/scsh_packages/scsh-install-lib-1.1.0.tar.gz>)
+
+  - Version 0.6 of Sunterlib, the Scheme Untergrund library
+    (From <http://savannah.nongnu.org/download/sunterlib/sunterlib-0.6.tar.gz>)
+
+* Installation
+
+  Run the script install.scm from the top of the tarball:
+
+  ./install.scm
+
+  The only important option is --prefix to specify a directory where
+  files are installed. Use the --help options to see all possible
+  options.
+
+* Patches for scsh
+
+  The following patches fix two little bugs in the scsh source tree
+  found during the development of Commander S.
+
+Index: scsh/procobj.scm
+===================================================================
+RCS file: /cvsroot/scsh/scsh/scsh/procobj.scm,v
+retrieving revision 1.22
+diff -u -r1.22 procobj.scm
+--- scsh/procobj.scm	14 Aug 2002 14:45:33 -0000	1.22
++++ scsh/procobj.scm	5 Jul 2005 15:11:50 -0000
+@@ -345,8 +345,10 @@
+ 
+ ;;; All you have to do, if a wait on proc was successful
+ (define (waited-by-wait proc status)
+-  (obituary proc status)
+-  (mark-proc-waited! proc))
++  (if (not (status:stop-sig status))
++      (begin
++	(obituary proc status)
++	(mark-proc-waited! proc))))
+ 
+ ;;; we know from somewhere that proc is dead
+ (define (obituary proc status)
+
+Index: scsh-interfaces.scm
+===================================================================
+RCS file: /cvsroot/scsh/scsh/scsh/scsh-interfaces.scm,v
+retrieving revision 1.55.2.5
+retrieving revision 1.55.2.6
+diff -u -c -r1.55.2.5 -r1.55.2.6
+*** scsh-interfaces.scm	15 Apr 2004 13:01:35 -0000	1.55.2.5
+--- scsh-interfaces.scm	30 May 2005 12:59:05 -0000	1.55.2.6
+***************
+*** 406,411 ****
+--- 406,412 ----
+  
+  (define-interface scsh-user/group-db-interface
+    (export user-info
++           user-info?
+  	  user-info:name
+  	  user-info:uid
+  	  user-info:gid
+***************
+*** 416,421 ****
+--- 417,423 ----
+  	  ->username
+  
+  	  group-info
++           group-info?
+  	  group-info:name
+  	  group-info:gid
+  	  group-info:members
+

install.scm

@@ -0,0 +1,27 @@
+#!/bin/sh
+exec scsh -lel install-lib/load.scm -dm -o install-commander-s -e install-program-main -s "$0" "$@"
+!#
+
+(define-structure install-commander-s (export install-program-main)
+  (open scheme-with-scsh
+	install-lib)
+  (begin
+    (define commander-s-template #<<END
+#!/bin/sh
+exec scsh -lel afs/load.scm -lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm ~a/debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm ~a/nuit-packages.scm -m nuit -s "$0"
+!#
+(nuit)
+
+END
+)
+
+(define-program "commander-s" (0 1) ((install-lib-version (1 1)))
+  (install-directory-contents "scheme" 'scheme)
+  (install-string (format #f commander-s-template 
+			  (get-directory 'scheme #f) (get-directory 'scheme #f))
+		  "commander-s"
+		  'bin
+		  "."
+		  #o555))))
+
+

scheme/afs.scm

@@ -1,3 +1,63 @@
+;; We are assuming that the vos and fs commands follow the OpenAFS
+;; syntax.
+
+(define *afs-volumes-cs* (make-empty-completion-set))
+
+(define (read-volume-names)
+  (port-fold
+   (run/port ("vos" "listvldb"))
+   read-line
+   (lambda (line s)
+     (if-match
+      (regexp-search
+       (rx (submatch (: bos (+ alphanumeric) (* (| punctuation alphanumeric)))))
+       line)
+      (whole match)
+      (cons match s)
+      s))
+   '()))
+
+(spawn
+ (lambda ()
+   (set! *afs-volumes-cs* (make-completion-set (read-volume-names)))))
+
+(define fs-command-cs
+  (make-completion-set
+   '("apropos" "checkservers" "checkvolumes" "cleanacl"
+     "copyacl" "diskfree" "examine" "exportafs"
+     "flush" "flushmount" "flushvolume"
+     "getcacheparms" "getcellstatus"
+     "getclientaddrs" "getcrypt" "getserverprefs"
+     "help" "listacl" "listaliases" "listcells"
+     "listquota" "lsmount" "messages" "mkmount"
+     "newalias" "newcell" "quota" "rmmount"
+     "rxstatpeer" "rxstatproc" "setacl"
+     "setcachesize" "setcell" "setclientaddrs"
+     "setcrypt" "setquota" "setserverprefs"
+     "setvol" "storebehind" "sysname"
+     "whereis" "whichcell" "wscell")))
+
+(define vos-command-cs
+  (make-completion-set
+   '("addsite" "apropos" "backup" "backupsys"
+     "changeaddr" "changeloc" "create" "delentry"
+     "dump" "examine" "help" "listaddrs" "listpart"
+     "listvldb" "listvol" "lock" "move" "partinfo"
+     "release" "remove" "remsite" "rename" "restore"
+     "setfields" "status" "syncserv" "syncvldb"
+     "unlock" "unlockvldb" "zap")))
+
+;; FIXME: Not all vos commands expect a volume argument
+(define (vos-command-completer command prefix args arg-pos)
+  (if (= 1 arg-pos)
+      (completions-for vos-command-cs prefix)
+      (completions-for *afs-volumes-cs* prefix)))
+
+;; FIXME: Not all fs commands expect a volume argument
+(define (fs-command-completer command prefix args arg-pos)
+  (if (= 1 arg-pos)
+      (completions-for fs-command-cs prefix)
+      (completions-for *afs-volumes-cs* prefix)))
 
 (define-record-type acl :acl
   (make-acl dir afs-perms)
@@ -5,6 +65,8 @@
   (dir acl-dir)
   (afs-perms acl-afs-perms))
 
+(define key-d 100)
+(define delete-key key-d)
 
 (define (make-header width dir)
   (list
@@ -30,12 +92,24 @@
 (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))
+         (num-cols (result-buffer-num-cols buffer))
+         (num-lines (result-buffer-num-lines buffer))
+         (header (make-header num-cols dir))
          (select-list
           (make-afs-perms-select-list
-           (result-buffer-num-cols buffer)
+           num-cols
-          (- (result-buffer-num-lines buffer) (length header))
+           (- num-lines (length header))
-          afs-perms)))
+           afs-perms)))
+
+    (define (delete-selected-entry!)
+      (let ((uid.afs-perms (select-list-selected-entry select-list)))
+        (set! afs-perms (delete uid.afs-perms afs-perms eq?))
+        (set! select-list
+              (make-afs-perms-select-list num-lines
+                                          (- num-lines (length header))
+                                          afs-perms))
+        (set-acl! dir afs-perms)))
+
     (lambda (message)
       (case message
 
@@ -51,9 +125,13 @@
 
        ((key-press)
 	(lambda (self key control-x-pressed?)
-	  (set! select-list
+          (cond
-		(select-list-handle-key-press select-list key))
+           ((= key delete-key)
-	  self))
+            (delete-selected-entry!))
+           (else
+            (set! select-list
+                  (select-list-handle-key-press select-list key))))
+          self))
 
 ;       ((get-selection) get-selection)	
 
@@ -63,17 +141,24 @@
 	(error "acl viewer unknown message" message))))))
 
 (register-plugin!
- (make-command-plugin "fs"
+ (make-command-plugin 
-                      (lambda args #f)
+  "fs"
-                      (lambda (command args)
+  fs-command-completer
-                        (cond
+  (lambda (command args)
-                         ((or (string=? (car args) "la")
+    (cond
-                              (string=? (car args) "listacl"))
+     ((or (string=? (car args) "la")
-                          (make-acl (cadr args)
+	  (string=? (car args) "listacl"))
-                                    (get-acl (cadr args))))
+      (let ((dir (if (null? (cdr args)) (cwd) (cadr args))))
-                         (else
+	(make-acl dir (get-acl dir))))
-                          (display "unsupported fs command" (car args)))))))
+     (else
-
+      (display "unsupported fs command" (car args)))))))
 
 (register-plugin!
- (make-view-plugin make-acl-viewer acl?))
+ (make-view-plugin make-acl-viewer acl?))
+
+(register-plugin!
+ (make-command-plugin
+  "vos"
+  vos-command-completer
+  (lambda (command args)
+    (run/fg (,command ,@args)))))

scheme/browse-directory-list.scm

@@ -200,13 +200,11 @@
       (define (prepare-selection-for-scheme-mode file-names)
 	(string-append "'" (exp->string file-names)))
 
+      ;; FIXME: quote file names containing space etc
       (define (prepare-selection-for-command-mode file-names)
-	(string-join
+	(string-join file-names))
-	 (map (lambda (file-name)
-		(string-append "\"" file-name "\""))
-	      file-names)))
 
-      (define (get-selection self for-scheme-mode? focus-object-table)
+      (define (get-selection-as-text self for-scheme-mode? focus-object-table)
 	(let* ((marked (select-list-get-selection select-list))
 	       (file-names
 		(map fs-object-complete-path
@@ -218,7 +216,7 @@
 	       prepare-selection-for-command-mode)
 	   file-names)))
 
-      (define (get-focus-object self focus-object-table)
+      (define (get-selection-as-ref self focus-object-table)
 	(let ((marked (select-list-get-selection select-list))
 	      (make-reference (lambda (obj)
 				(make-focus-object-reference 
@@ -242,11 +240,11 @@
 	  (lambda (self key control-x-pressed?)
 	    (handle-key-press self key)))
 
-	 ((eq? message 'get-selection)
+	 ((eq? message 'get-selection-as-text)
-	  get-selection)
+	  get-selection-as-text)
 
-	 ((eq? message 'get-focus-object)
+	 ((eq? message 'get-selection-as-ref)
-	  get-focus-object)
+	  get-selection-as-ref)
        
 	 (else
 	  (error "fsobjects-viewer unknown message" message)))))))
@@ -257,4 +255,7 @@
 
 (register-plugin! 
  (make-view-plugin make-fsobjects-viewer
-		   list-of-fs-objects?))
+		   (lambda (thing)
+		     (or (fs-object? thing)
+			 (list-of-fs-objects? thing)))))
+			 

scheme/console.scm

@@ -37,7 +37,7 @@
 	 window terminal-buffer pty-channel)
   (spawn 
    (lambda ()
-     (let lp ((paint? #t))
+     (let lp ((paint? #f))
        (select
 	(wrap (receive-rv pause-channel)
 	      (lambda (ignore)

scheme/eval.scm

@@ -24,6 +24,6 @@
 (define (focus-table)
   *focus-table*)
 
-(define (focus-value id)
+(define (focus-value-ref id)
   (get-focus-object (focus-table) id))
 

scheme/inspector.scm

@@ -152,7 +152,7 @@
                    (- num-lines (header-length header))
                    val)))))
 
-    (define (get-focus-object self focus-object-table)
+    (define (get-selection-as-ref self focus-object-table)
       (let ((marked (select-list-get-selection selection-list))
             (make-reference (lambda (obj)
                               (make-focus-object-reference 
@@ -165,7 +165,7 @@
              (string-join (map exp->string (map make-reference marked)))
              ")"))))
 
-    (define (get-selection self for-scheme-mode? focus-object-table)
+    (define (get-selection-as-text self for-scheme-mode? focus-object-table)
       (if for-scheme-mode?
           (let ((marked (select-list-get-selection selection-list)))
             (prepare-selection-for-scheme-mode marked))
@@ -198,10 +198,10 @@
                    (select-list-handle-key-press
                     selection-list key))))
            self))
-        ((get-focus-object)
+        ((get-selection-as-ref)
-         get-focus-object)
+         get-selection-as-ref)
-        ((get-selection)
+        ((get-selection-as-text)
-         get-selection)
+         get-selection-as-text)
         (else
          (debug-message "inspector did not handle message " message))))))
 

scheme/job-viewer.scm

@@ -62,12 +62,12 @@
 		jobs)
 	   (- (result-buffer-num-lines buffer) 1))))
 
-    (define get-focus-object
+    (define get-selection-as-ref
-      (make-get-focus-object-method select-list))
+      (make-get-selection-as-ref-method select-list))
 
-    (define (get-selection self for-scheme-mode? focus-object-table)
+    (define (get-selection-as-text self for-scheme-mode? focus-object-table)
       (if for-scheme-mode?
-	  (send self 'get-focus-object focus-object-table)
+	  (send self 'get-selection-as-ref focus-object-table)
 	  (let ((marked (select-list-get-selection select-list)))
 	    (if (null? marked)
 		(number->string 
@@ -93,9 +93,9 @@
 		 (select-list-handle-key-press select-list key))
 	   self))
 
-	((get-selection) get-selection)	
+	((get-selection-as-text) get-selection-as-text)	
 	
-	((get-focus-object) get-focus-object)
+	((get-selection-as-ref) get-selection-as-ref)
 	
 	(else 
 	 (error "joblist-viewer unknown message" message))))))
@@ -111,7 +111,11 @@
 (define (make-job-viewer job buffer)
   (let ((select-list #f)
 	(num-cols 
-	 (- (result-buffer-num-cols buffer) 1)))
+	 (- (result-buffer-num-cols buffer) 1))
+	(console-viewer 
+	 (if (job-with-console? job)
+	     (make-console-viewer (job-console job) buffer)
+	     #f)))
 
     (define (make-job-select-list job)
       (make-select-list
@@ -144,22 +148,24 @@
 	  (#f "run status:"
 	      ,(format-job-run-state job))
 	  ,@(if (job-with-console? job)
-		`((,(job-console job) "<View Console>" ""))
+		`((,console-viewer "<View Console>" ""))
 		'())))
        (- (result-buffer-num-lines buffer) 1)))
 
     (define (handle-key-press self key control-x-pressed?)
       (cond
        ((= key (char->ascii #\f))
-	(continue-job-in-foreground job))
+	(continue-job-in-foreground job)
+	self)
        ((= key (char->ascii #\g))
-	(set! select-list (make-job-select-list job)))
+	(set! select-list (make-job-select-list job))
+	self)
        ((= key (char->ascii #\newline))
 	(select-list-selected-entry select-list))
        (else
 	(set! select-list
-	      (select-list-handle-key-press select-list key))))
+	      (select-list-handle-key-press select-list key))
-      self)
+	self)))
 
     (set! select-list (make-job-select-list job))
 
@@ -178,11 +184,11 @@
 
 	((key-press) handle-key-press)
 
-	((get-selection) 
+	((get-selection-as-text)
-	 (make-get-focus-object-method select-list))
+	 (make-get-selection-as-ref-method select-list))
 
-	((get-focus-object) 
+	((get-selection-as-ref) 
-	 (make-get-focus-object-method select-list))
+	 (make-get-selection-as-ref-method select-list))
 
 	(else
 	 (error "job viewer unknown message" message))))))

scheme/job.scm

@@ -155,6 +155,11 @@
     (send get-job-list-channel (cons 'ready answer-channel))
     (receive answer-channel)))
 
+(define (stopped-jobs)
+  (let ((answer-channel (make-channel)))
+    (send get-job-list-channel (cons 'stopped answer-channel))
+    (receive answer-channel)))
+
 (define (clear-ready-jobs!)
   (send clear-ready-jobs-channel 'ignored))
 
@@ -279,7 +284,7 @@
     (thunk)
     (set-tty-info/now port settings)))
 
-(define-syntax run-with-console
+(define-syntax run/console
   (syntax-rules ()
     ((_ epf)
      (call-with-values
@@ -295,37 +300,45 @@
 	   (- (result-buffer-num-cols (result-buffer)) 1)
 	   (- (result-buffer-num-lines (result-buffer)) 1))))))))
 
-(define-syntax go
+(define-syntax run/fg
+  (syntax-rules ()
+    ((_ epf)
+     (save-tty-excursion
+      (current-input-port)
+      (lambda ()
+	(def-prog-mode)
+	(clear)
+	(endwin)
+	(restore-initial-tty-info! (current-input-port))
+	(drain-tty (current-output-port))
+	(obtain-lock paint-lock)
+	(let ((foreground-pgrp (tty-process-group (current-output-port)))
+	      (proc 
+	       (fork 
+		(lambda () 
+		  (set-process-group (pid) (pid))
+		  (set-tty-process-group (current-output-port) (pid))
+		  (exec-epf epf)))))
+	  (job-status (make-job-sans-console (quote epf) proc))
+	  (set-tty-process-group (current-output-port) foreground-pgrp)
+	  (display "Press any key to return to Commander S...")
+	  (wait-for-key)
+	  (release-lock paint-lock)))))))
+
+(define-syntax run/bg
   (syntax-rules ()
     ((_ epf)
      (begin
-       (def-prog-mode)
-       (clear)
-       (endwin)
        (obtain-lock paint-lock)
-       (let ((proc
+       (drain-tty (current-output-port))
-	      (fork
+       (set-tty-process-group (current-output-port) (pid))
-	       (lambda ()
-		 (set-process-group (pid) (pid))
-		 (set-tty-process-group 
-		  (current-output-port) (pid))
-		 (exec-epf epf)))))
-	 (job-status 
-	  (make-job-sans-console (quote epf) proc))
-	 (set-tty-process-group 
-	  (current-output-port) (pid))
-	 (display "Press any key to return to Commander S...")
-	 (wait-for-key)
-	 (release-lock paint-lock))))))
-
-(define-syntax go/bg
-  (syntax-rules ()
-    ((_ epf)
        (let ((proc
  	      (fork
  	       (lambda ()
 		 (set-process-group (pid) (pid))
  		 (exec-epf epf)))))
- 	 (make-job-sans-console (quote epf) proc)))))
+ 	 (let ((job (make-job-sans-console (quote epf) proc)))
+	   (release-lock paint-lock)
+ 	   job))))))
 
-;;; EOF
+;;; EOF

scheme/nuit-engine.scm

@@ -118,9 +118,11 @@
 ;;start the whole thing
 (define (nuit)
   (let ((tty-name (init-tty-debug-output!)))
-    (display "Debug messages will be on ")
+    (if tty-name
-    (display tty-name)
+	(begin
-    (newline))
+	  (display "Debug messages will be on ")
+	  (display tty-name)
+	  (newline))))
   (with-inspecting-handler
    8888
    (lambda (condition)
@@ -223,7 +225,7 @@
 (define (paste-selection/refresh viewer)
   (add-string-to-command-buffer
    (send (current-viewer) 
-	 'get-selection 
+	 'get-selection-as-text
 	 (command-buffer-in-scheme-mode?) (focus-table)))
   (print-command-buffer (app-window-curses-win (command-window))
 			(command-buffer))
@@ -234,10 +236,10 @@
   (add-string-to-command-buffer
    (if (command-buffer-in-command-mode?)
        (send (current-viewer) 
-	     'get-selection 
+	     'get-selection-as-text
 	     (command-buffer-in-scheme-mode?)
 	     (focus-table))
-       (send (current-viewer) 'get-focus-object (focus-table))))
+       (send (current-viewer) 'get-selection-as-ref (focus-table))))
   (print-command-buffer (app-window-curses-win (command-window))
 			(command-buffer))
   (move-cursor (command-buffer) (result-buffer))
@@ -459,7 +461,7 @@
 	     (make-completion-set-for-executables (get-path-list)))))))
 
 (define (paint-bar-1)
-  (mvwaddstr (app-window-curses-win (bar-1)) 0 1 "SCSH-NUIT")
+  (mvwaddstr (app-window-curses-win (bar-1)) 0 1 "Commander S")
   (wrefresh (app-window-curses-win (bar-1))))
 
 (define (paint-command-buffer-mode-indicator)
@@ -570,6 +572,9 @@
 
 (define (find/init-plugin-for-result result)
   (cond
+   ;; #### a hack
+   ((null? result)
+    (make-standard-viewer result (result-buffer)))
    ((determine-plugin-by-type result)
     => (lambda (view-plugin)
 	 ((view-plugin-constructor view-plugin)

scheme/nuit-packages.scm

@@ -170,10 +170,13 @@
   (open scheme-with-scsh
         afs-fs
         define-record-types
-        (subset srfi-1 (iota))
+        (subset srfi-1 (iota delete))
+	threads
 
         ncurses
         select-list
+	completion-sets
+	run-jobs
         plugin
         layout)
   (files afs))
@@ -227,8 +230,11 @@
 	signals
 	srfi-1
 	srfi-13
-        
+	srfi-37
+	sorting
+
 	joblist
+	jobs
 	layout
         fs-object
 	pps
@@ -290,7 +296,7 @@
 	  select-list-navigation-key?
 	  select-list-marking-key?
 
-	  make-get-focus-object-method))
+	  make-get-selection-as-ref-method))
 
 (define-structure select-list select-list-interface
   (open scheme
@@ -322,6 +328,7 @@
 	ncurses
 	focus-table
 	select-list
+	tty-debug
 	plugin
 	layout)
   (files job-viewer))
@@ -359,7 +366,7 @@
 (define-structures
   ((nuit-eval (compound-interface 
 	       (interface-of scheme-with-scsh)
-	       (export focus-value)
+	       (export focus-value-ref)
 	       run-jobs-interface))
    (nuit-eval/focus-table (export focus-table)))
   (open 
@@ -454,6 +461,7 @@
 (define-interface console-interface
   (export
    make-console
+   make-console-viewer
    console?
    view-console
    pause-console-output
@@ -500,6 +508,7 @@
 
 	  running-jobs
 	  ready-jobs
+	  stopped-jobs
 	  clear-ready-jobs!
 	  jobs-with-new-output
 	  jobs-waiting-for-input
@@ -512,9 +521,9 @@
 
 (define-interface run-jobs-interface
   (export
-   (run-with-console :syntax)
+   (run/console :syntax)
-   (go :syntax)
+   (run/fg :syntax)
-   (go/bg :syntax)))
+   (run/bg :syntax)))
 
 (define-interface joblist-interface
   (export running-jobs

scheme/process.scm

@@ -48,14 +48,20 @@
           processes))
 	(header (make-header-line (result-buffer-num-cols buffer))))
 
-    (define (get-selection self for-scheme-mode? focus-object-table)
+    (define (get-selection-as-text self for-scheme-mode? focus-object-table)
-      (let ((marked (select-list-get-selection select-list)))
+      (let* ((marked (select-list-get-selection select-list)))
-	(if (null? marked)
+	(cond
-	    (number->string 
+	 ((null? marked)
-	     (process-info-pid
+	  (number->string 
-	      (select-list-selected-entry select-list)))
+	   (process-info-pid
-	    (string-append
+	    (select-list-selected-entry select-list))))
-	     "'"(exp->string (map process-info-pid marked))))))
+	 (for-scheme-mode?
+	  (string-append
+	   "'" (exp->string (map process-info-pid marked))))
+	 (else
+	  (string-join 
+	   (map number->string
+		(map process-info-pid marked)))))))
 
     (lambda (message)
 
@@ -73,10 +79,10 @@
 		(select-list-handle-key-press select-list key))
 	  self))
 
-       ((get-selection) get-selection)	
+       ((get-selection-as-text) get-selection-as-text)
 
-       ((get-focus-object) 
+       ((get-selection-as-ref)
-	(make-get-focus-object-method select-list))
+	(make-get-selection-as-ref-method select-list))
        
        (else 
 	(error "pps-viewer unknown message" message))))))

scheme/select-list.scm

@@ -175,7 +175,7 @@
    (list-ref (select-list-elements select-list)
 	     (select-list-cursor-index select-list))))
 
-(define (make-get-focus-object-method select-list)
+(define (make-get-selection-as-ref-method select-list)
   (lambda (self focus-object-table)
     (let ((marked (select-list-get-selection select-list))
 	  (make-reference (lambda (obj)

scheme/std-command.scm

@@ -60,18 +60,69 @@
 
 (define no-completer (lambda args #f))
 
+;; Parse options for ls command using args-fold (SRFI 37)
+;; We don't care for options that format the output.
+
+(define defaults-ls-options
+  '((long . #t) (dot-files? . #t) 
+    (sort-by-mtime . #f) (reverse-sort . #f)))
+
+(define (parse-ls-arguments args)
+  (let* ((on/off-option-processor
+	  (lambda (name)
+	    (lambda (option arg-name arg ops)
+	      (cons (cons name #t) ops))))
+	 (long-option 
+	  (option '(#\l) #f #f 
+		  (on/off-option-processor 'long)))
+	 (dotfiles-option
+	  (option '(#\a) #f #f 
+		  (on/off-option-processor 'dot-files?)))
+	 (sort-mtime-option
+	  (option '(#\t) #f #f
+		  (on/off-option-processor 'sort-by-mtime)))
+	 (reverse-sort-option
+	  (option '(#\r) #f #f
+		  (on/off-option-processor 'reverse-sort))))
+    (let ((given-args
+	   (args-fold
+	    args
+	    (list long-option dotfiles-option 
+		  sort-mtime-option reverse-sort-option)
+	    (lambda (option name args operands)
+	      (error "Unknown ls option" name))
+	    cons '())))
+      (map (lambda (p)
+	     (or (assoc (car p) given-args) p))
+	   defaults-ls-options))))
+	 
 (register-plugin!
  (make-command-plugin 
   "ls"
   no-completer
   (lambda (command args)
-    (if (null? args)
+    (let* ((options (parse-ls-arguments args))
-        (directory-files (cwd))
+	   (set? (lambda (opt) (cdr (assoc opt options))))
-        (let ((arg (file-name->fs-object
+	   (sort
-                    (expand-file-name (car args) (cwd)))))
+	    (if (set? 'sort-by-mtime)
-          (if (file-info-directory? (fs-object-info arg))
+		(lambda (lst)
-              (directory-files (fs-object-complete-path arg))
+		  (list-sort 
-              arg))))))
+		   (lambda (f g)
+		     (< (file-info:mtime (fs-object-info f)) 
+			(file-info:mtime (fs-object-info g))))
+		   lst))
+		(lambda (lst)
+		  (list-sort 
+		   (lambda (f g)
+		     (string<? (fs-object-name f) (fs-object-name g)))
+		   lst))))
+	   (reverse 
+	    (if (set? 'reverse-sort)
+		reverse
+		(lambda (l) l))))
+      (reverse 
+       (sort
+	(directory-files (cwd) (set? 'dot-files?))))))))
 
 (register-plugin!
  (make-command-plugin "ps"
@@ -124,20 +175,23 @@
 (register-plugin!
  (make-command-plugin "jobs"
 		      (lambda (command prefix args arg-pos)
-			'("running" "ready" "output" "waiting-for-input"))
+			'("running" "ready" "stopped" "output" "waiting-for-input"))
 		      (lambda (command args)
-			(append-map
+			(let ((selectors
-			 (lambda (arg)
+			       `(("running" . ,running-jobs)
-			   ;; #### warn if argument is unknown
+				 ("ready" . ,ready-jobs)
-			   (cond
+				 ("stopped" . ,stopped-jobs)
-			    ((assoc arg
+				 ("output" . ,jobs-with-new-output)
-				    `(("running" . ,running-jobs)
+				 ("input" . ,jobs-waiting-for-input))))
-				      ("ready" . ,ready-jobs)
+			  (append-map
-				      ("output" . ,jobs-with-new-output)
+			   (lambda (arg)
-				      ("input" . ,jobs-waiting-for-input)))
+			     (cond
-			     => (lambda (p)
+			      ((assoc arg selectors)
-				  ((cdr p))))))
+			       => (lambda (p)
-			 (delete-duplicates args)))))
+				    ((cdr p))))))
+			   (if (null? args)
+			       (map car selectors)
+			       (delete-duplicates args)))))))
 
 (register-plugin!
  (make-command-plugin 
@@ -149,5 +203,5 @@
      (else
       '("ftp.gnu.org" "ftp.x.org"))))
   (lambda (command args)
-    (run (,command ,@args)))))
+    (run/fg (,command ,@args)))))
 

scheme/tty-debug.scm

@@ -1,19 +1,24 @@
+(define debug-mode #t)
+
 (define *tty-port* #f)
 
 (define (init-tty-debug-output!)
-  (call-with-values 
+  (and debug-mode
-      open-pty
+       (call-with-values 
-    (lambda (input-port name)
+	   open-pty
-      (set! *tty-port* (dup->outport input-port))
+	 (lambda (input-port name)
-      (close input-port)
+	   (set! *tty-port* (dup->outport input-port))
-      (set-port-buffering *tty-port* bufpol/none)
+	   (close input-port)
-      name)))
+	  (set-port-buffering *tty-port* bufpol/block 8192)
+	  name))))
 
 (define debug-message
   (lambda args
-    (with-current-output-port*
+    (if debug-mode
-     *tty-port*
+	(with-current-output-port*
-     (lambda ()
+	 *tty-port*
-       (for-each display args)
+	 (lambda ()
-       (newline)))))
+	   (for-each display args)
+	   (newline)
+	   (flush-tty/output *tty-port*))))))