Clean up code releated for handling messages. Add a new plugin for

pps (portable ps)

scheme/browse-directory-list.scm

@@ -176,7 +176,7 @@
 	      browse-obj))))
 
      ((print-message? message)
-      (let* ((model (print-message-object message))
+      (let* ((model (message-result-object message))
 	     (pos-y (browse-dir-list-res-obj-pos-y model))
 	     (pos-x (browse-dir-list-res-obj-pos-x model))
 	     (text (browse-dir-list-res-obj-result-text model))
@@ -186,7 +186,7 @@
 	(make-print-object pos-y pos-x text (list pos-y) marked-pos))) 
 
      ((key-pressed-message? message)
-      (let* ((model (key-pressed-message-result-model message))
+      (let* ((model (message-result-object message))
 	     (key (key-pressed-message-key message))
 	     (c-x-pressed (browse-dir-list-res-obj-c-x-pressed model)))
 	
@@ -344,12 +344,12 @@
 
 
      ((restore-message? message)
-      (let* ((model (restore-message-object message))
+      (let* ((model (message-result-object message))
 	     (initial-wd (browse-dir-list-res-obj-initial-wd model)))
 	(chdir initial-wd)))
      
      ((selection-message? message)
-      (let* ((model (selection-message-object message))
+      (let* ((model (message-result-object message))
 	     (marked-items (browse-dir-list-res-obj-res-marked-items model)))
 	(string-append "'" (exp->string marked-items)))))))
 

scheme/browse-list.scm

@@ -152,7 +152,7 @@
 		    browse-obj))))))
 
      ((print-message? message)
-      (let* ((model (print-message-object message))
+      (let* ((model (message-result-object message))
 	     (pos-y (browse-list-res-obj-pos-y model))
 	     (pos-x (browse-list-res-obj-pos-x model))
 	     (text (browse-list-res-obj-result-text model))
@@ -169,7 +169,7 @@
 	(make-print-object pos-y pos-x text highlighted real-marked-pos)))
 
      ((key-pressed-message? message)
-      (let* ((model (key-pressed-message-result-model message))
+      (let* ((model (message-result-object message))
 	     (key (key-pressed-message-key message))
 	     (c-x-pressed (browse-list-res-obj-c-x-pressed model)))
 
@@ -331,7 +331,7 @@
 	    
 	    
      ((selection-message? message)
-      (let* ((model (selection-message-object message))
+      (let* ((model (message-result-object message))
 	     (marked-items (browse-list-res-obj-marked-items model)))
 	(string-append "'" (exp->string marked-items))))
 

scheme/cd.scm

@@ -47,7 +47,7 @@
 		       (make-cd-res-obj (browse-dir-list-receiver 
 					 browse-next-command-message)))))))))
      ((print-message? message)
-      (let* ((model (print-message-object message))
+      (let* ((model (message-result-object message))
 	     (width (print-message-width message))
 	     (browser (cd-res-obj-browse-obj model))
 	     (browse-print-message 
@@ -56,7 +56,7 @@
 				  width)))
 	(browse-dir-list-receiver browse-print-message)))
      ((key-pressed-message? message)
-      (let* ((model (key-pressed-message-result-model message))
+      (let* ((model (message-result-object message))
 	     (key (key-pressed-message-key message))
 	     (browser (cd-res-obj-browse-obj model))
 	     (browse-key-message 
@@ -67,12 +67,12 @@
 				browse-key-message))))
 	     
      ((restore-message? message)
-      (let* ((model (restore-message-object message))
+      (let* ((model (message-result-object message))
 	     (browser (cd-res-obj-browse-obj model))
 	     (wd (browse-dir-list-res-obj-working-directory browser)))
 	(chdir wd)))
      ((selection-message? message)
-      (let* ((model (selection-message-object message))
+      (let* ((model (message-result-object message))
 	     (browser (cd-res-obj-browse-obj model))
 	     (browse-sel-message
 	      (make-selection-message "browse-dir-list"

scheme/directory-files.scm

@@ -26,7 +26,7 @@
       (make-dirfiles-res-obj (browse-dir-list-receiver 
 			      browse-next-command-message))))
      ((print-message? message)
-      (let* ((model (print-message-object message))
+      (let* ((model (message-result-object message))
 	     (width (print-message-width message))
 	     (browser (dirfiles-res-obj-browse-obj model))
 	     (browse-print-message 
@@ -35,7 +35,7 @@
 				  width)))
 	(browse-dir-list-receiver browse-print-message)))
      ((key-pressed-message? message)
-      (let* ((model (key-pressed-message-result-model message))
+      (let* ((model (message-result-object message))
 	     (key (key-pressed-message-key message))
 	     (browser (dirfiles-res-obj-browse-obj model))
 	     (browse-key-message 
@@ -46,14 +46,14 @@
 				browse-key-message))))
 	     
      ((restore-message? message)
-      (let* ((model (restore-message-object message))
+      (let* ((model (message-result-object message))
 	     (browser (dirfiles-res-obj-browse-obj model))
 	     (browse-restore-message
 	      (make-restore-message "browse-dir-list"
 				    browser)))
 	(browse-dir-list-receiver browse-restore-message)))
      ((selection-message? message)
-      (let* ((model (selection-message-object message))
+      (let* ((model (message-result-object message))
 	     (browser (dirfiles-res-obj-browse-obj model))
 	     (browse-sel-message
 	      (make-selection-message "browse-dir-list"

scheme/find.scm

@@ -45,7 +45,7 @@
 	      (make-find-res-obj (browse-list-receiver 
 				  browse-next-command-message))))))
      ((print-message? message)
-      (let* ((model (print-message-object message))
+      (let* ((model (message-result-object message))
 	     (width (print-message-width message))
 	     (browser (find-res-obj-browse-obj model))
 	     (browse-print-message 
@@ -54,7 +54,7 @@
 				  width)))
 	(browse-list-receiver browse-print-message)))
      ((key-pressed-message? message)
-      (let* ((model (key-pressed-message-result-model message))
+      (let* ((model (message-result-object message))
 	     (key (key-pressed-message-key message))
 	     (browser (find-res-obj-browse-obj model))
 	     (browse-key-message 
@@ -65,14 +65,14 @@
 				browse-key-message))))
 	     
      ((restore-message? message)
-      (let* ((model (restore-message-object message))
+      (let* ((model (message-result-object message))
 	     (browser (find-res-obj-browse-obj model))
 	     (browse-restore-message
 	      (make-restore-message "browse-ist"
 				    browser)))
 	(browse-list-receiver browse-restore-message)))
      ((selection-message? message)
-      (let* ((model (selection-message-object message))
+      (let* ((model (message-result-object message))
 	     (browser (find-res-obj-browse-obj model))
 	     (browse-sel-message
 	      (make-selection-message "browse-list"

scheme/go

@@ -1,4 +1,5 @@
 #!/bin/sh
-args="-lel module-system/load.scm -lel interaction/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
+args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/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/nuit-engine.scm

@@ -144,7 +144,7 @@
 ;;---------------------
 ;;A new command was entered
 ;;->create a new "object"
-(define-record-type next-command-message next-command-message
+(define-record-type next-command-message :next-command-message
   (make-next-command-message command-string
 			     parameters
 			     width)
@@ -156,27 +156,27 @@
 ;;key pressed
 ;;The object and the key are send to the user-code, who returns the
 ;;changed object.
-(define-record-type key-pressed-message key-pressed-message
+(define-record-type key-pressed-message :key-pressed-message
   (make-key-pressed-message command-string
-			    result-model
+			    result-object
 			    key)
   key-pressed-message?
   (command-string key-pressed-command-string)
-  (result-model key-pressed-message-result-model)
+  (result-object key-pressed-message-result-object)
   (key key-pressed-message-key))
 
 ;;print
-(define-record-type print-message print-message
+(define-record-type print-message :print-message
   (make-print-message command-string
-		      object
+		      result-object
 		      width)
   print-message?
   (command-string print-message-command-string)
-  (object print-message-object)
+  (result-object print-message-result-object)
   (width print-message-width))
 
 ;;->this sort of data-type is returned by a print-message 
-(define-record-type print-object print-object
+(define-record-type print-object :print-object
   (make-print-object pos-y
 		     pos-x
 		     text
@@ -189,25 +189,56 @@
   (marked-lines print-object-marked-lines))
 
 ;;restore (when side-effects occur)
-(define-record-type restore-message restore-message
+(define-record-type restore-message :restore-message
   (make-restore-message command-string
-			object)
+			result-object)
   restore-message?
   (command-string restore-message-command-string)
-  (object restore-message-object))
+  (result-object restore-message-result-object))
 
 ;;request the selection
-(define-record-type selection-message selection-message
+(define-record-type selection-message :selection-message
   (make-selection-message command-string
-			  object)
+			  result-object)
   selection-message?
   (command-string selection-message-command-string)
-  (object selection-message-object))
+  (result-object selection-message-result-object))
+
+(define (message-result-object message)
+  ((cond 
+    ((key-pressed-message? message) 
+     key-pressed-message-result-object)
+    ((print-message? message) 
+     print-message-result-object)
+    ((restore-message? message) 
+     restore-message-result-object)
+    ((selection-message? message) 
+     selection-message-result-object message)
+    (else 
+     (error "This message-type has no field for result-objects"
+	    message)))
+   message))
+
+(define (message-command-string message)
+  ((cond
+    ((next-command-message? message)
+     next-command-string)
+    ((key-pressed-message? message)
+     key-pressed-command-string)
+    ((print-message? message)
+     print-message-command-string)
+    ((restore-message? message)
+     restore-message-command-string)
+    ((selection-message? message)
+     selection-message-command-string)
+    (else
+     (error "This message-type has no command field" message)))
+   message))
    
 ;;The "user" (who extends the functionality of NUIT) has to inform NUIT
 ;;about which function is meant to be the receiver, when a certain
 ;;command is active
-(define-record-type receiver receiver
+(define-record-type receiver :receiver
   (make-receiver command rec)
   receiver?
   (command receiver-command)
@@ -330,7 +361,10 @@
 		      (text (sublist (buffer-text command-buffer) 0 
 				     (- (length (buffer-text command-buffer)) 1))))
 		  (begin
-		    (switch restore-message)
+		    ;; is this correct?
+		    (switch (make-restore-message 
+			     command-string 
+			     current-result-object))
 		    (set-buffer-text! (append text (list command-string)))
 		    (execute-command)
 		    (set-buffer-history-pos! command-buffer
@@ -633,33 +667,17 @@
 ;;Message-Passing
 ;;switch manages that the messages are delivered in the correct way
 (define (switch message)
-  (let ((command ""))
   (cond
-     ((next-command-message? message)
+   ((get-receiver (message-command-string message))
-      (set! command (next-command-string message)))
+    => (lambda (receiver)
-     ((key-pressed-message? message)
+	 ((receiver-rec receiver) message)))
-      (set! command (key-pressed-command-string message)))
+   (else 
-     ((print-message? message)
+    (standard-receiver message))))
-      (set! command (print-message-command-string message)))
-     ((restore-message? message)
-      (set! command (restore-message-command-string message)))
-     ((selection-message? message)
-      (set! command (selection-message-command-string message))))
-    (let ((receiver (get-receiver command)))
-      (if receiver
-	  (receiver message)
-	  (standard-receiver message)))))
 
 (define (get-receiver command)
-  (let loop ((recs receivers))
+  (find (lambda (r)
-    (if (= 0 (length recs))
+	  (string=? (receiver-command r) command))
-	#f
+	receivers))
-	(let* ((act-rec (car recs))
-	       (act-com (receiver-command act-rec))
-	       (act-rec-proc (receiver-rec act-rec)))
-	  (if (equal? command act-com)
-	      act-rec-proc
-	      (loop (cdr recs)))))))
 
 ;;Management of the upper buffer
 ;;add a char to the buffer
@@ -832,22 +850,10 @@
 
 ;;compue pos-x and pos-y
 (define (compute-y-x)
-  (if (focus-on-command-buffer?)
-      (begin
-	(if (>= (buffer-pos-fin-ln command-buffer) 
-		(buffer-num-lines command-buffer))
-	    (set-buffer-pos-y! command-buffer 
-			       (buffer-num-lines command-buffer))
-	    (set-buffer-pos-y! command-buffer
-			       (buffer-pos-fin-ln command-buffer)))
-	(let ((posx (modulo (buffer-pos-col command-buffer)
-			    (buffer-num-cols command-buffer))))
-	  (set-buffer-pos-x! command-buffer posx)))
-      (begin
   (if (>= pos-result result-lines)
       (set! result-buffer-pos-y result-lines)
       (set! result-buffer-pos-y pos-result))
-	(set! result-buffer-pos-x pos-result-col))))
+  (set! result-buffer-pos-x pos-result-col))
 
 
 ; ;;index of shortcuts at the bottom
@@ -965,7 +971,7 @@
    ((print-message? message)
     (make-print-object 1 1 shortcuts '() '()))
    ((key-pressed-message? message)
-    (key-pressed-message-result-model message))
+    (message-result-object message))
    ((restore-message? message)
     (values))
    ((selection-message? message)
@@ -1012,7 +1018,7 @@
 	      (make-standard-result-obj 1 1 text result)))
 	std-obj)))
    ((print-message? message)
-    (let* ((model (print-message-object message))
+    (let* ((model (message-result-object message))
 	   (pos-y (standard-result-obj-cur-pos-y model))
 	   (pos-x (standard-result-obj-cur-pos-x model))
 	   (width (print-message-width message))
@@ -1021,7 +1027,7 @@
 					 result width))) 
       (make-print-object pos-y pos-x text '() '())))
    ((key-pressed-message? message)
-    (key-pressed-message-result-model message))
+    (message-result-object message))
    ((restore-message? message)
     (values))
    ((selection-message? message)

scheme/nuit-packages.scm

@@ -9,15 +9,20 @@
 	signals 
 	handle
 	ncurses
+	srfi-1
 	srfi-6
+	srfi-13
 	debugging
 	inspect-exception
 	rt-modules
-	tty-debug)
+	tty-debug
+	pps)
   (files nuit-engine
 	 handle-fatal-error
 	 directory-files
 	 find
 	 cd
 	 browse-directory-list
-	 browse-list))
+	 browse-list
+	 process))
+

scheme/process.scm

@@ -0,0 +1,36 @@
+(define (print-processes processes)
+  (map (lambda (pi)
+	 (apply format 
+		(append
+		 (list #f 
+		       "~A ~A ~A ~A '~A ~A'~%")
+		 (map (lambda (s) (s pi))
+		      (list process-info-pid 
+			    process-info-ppid
+			    process-info-real-uid 
+			    process-info-%cpu
+			    process-info-executable
+			    process-info-command-line)))))
+       processes))
+
+(define (pps-receiver message)
+  (cond
+   ((next-command-message? message)
+    (pps))
+   ((print-message? message)
+    (let ((processes (message-result-object message)))
+      (make-print-object 1 1 (print-processes processes)
+			 '() '())))
+   ((key-pressed-message? message)
+    (pps))
+   ((restore-message? message)
+    (values))
+   ((selection-message? message)
+    "'()")))
+
+(set! receivers (cons (make-receiver "ps" pps-receiver) 
+		      receivers))
+   
+			 
+   
+