From 8ae60787a77187edbf6c7679fc993acaf1d71932 Mon Sep 17 00:00:00 2001
From: eknauel <eknauel>
Date: Sat, 4 Jun 2005 11:22:44 +0000
Subject: [PATCH] Add a joblist-viewer, add a get-focus-object-method generator
 to select-list and make some plugins use it, added argument
 focus-object-table to get-selection message (thus a get-selection method can
 call a get-focus-object method).

---
 scheme/browse-directory-list.scm |   2 +-
 scheme/inspector.scm             |   2 +-
 scheme/job-viewer.scm            | 107 +++++++++++++++++++++++++++++++
 scheme/job.scm                   |  38 +++++++++--
 scheme/nuit-engine.scm           |   9 ++-
 scheme/nuit-packages.scm         |  40 +++++++++++-
 scheme/process.scm               |  18 +-----
 scheme/select-list.scm           |  17 ++++-
 scheme/std-command.scm           |  13 +++-
 9 files changed, 216 insertions(+), 30 deletions(-)
 create mode 100644 scheme/job-viewer.scm

diff --git a/scheme/browse-directory-list.scm b/scheme/browse-directory-list.scm
index 6f4c34d..63841ba 100644
--- a/scheme/browse-directory-list.scm
+++ b/scheme/browse-directory-list.scm
@@ -206,7 +206,7 @@
 		(string-append "\"" file-name "\""))
 	      file-names)))
 
-      (define (get-selection self for-scheme-mode?)
+      (define (get-selection self for-scheme-mode? focus-object-table)
 	(let* ((marked (select-list-get-selection select-list))
 	       (file-names
 		(map fs-object-complete-path
diff --git a/scheme/inspector.scm b/scheme/inspector.scm
index fb9b8d1..85650df 100644
--- a/scheme/inspector.scm
+++ b/scheme/inspector.scm
@@ -165,7 +165,7 @@
              (string-join (map exp->string (map make-reference marked)))
              ")"))))
 
-    (define (get-selection self for-scheme-mode?)
+    (define (get-selection 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))
diff --git a/scheme/job-viewer.scm b/scheme/job-viewer.scm
new file mode 100644
index 0000000..402ca36
--- /dev/null
+++ b/scheme/job-viewer.scm
@@ -0,0 +1,107 @@
+(define (job-name->string name)
+  (let ((port (open-output-string)))
+    (display name port)
+    (get-output-string port)))
+
+(define (short-date date)
+  (fill-up-string 10
+    (format-date "~H:~M:~S" date)))
+
+(define (format-job-run-state job)
+  (fill-up-string 12
+    (cond 
+     ((job-running? job) "running")
+     ((job-ready? job) "ready")
+     ((job-waiting-for-input? job) "stop/input")
+     ((and (job-end-time job)
+	   (job-has-new-output? job) "ready/output"))
+     (else "run/output"))))
+
+(define (format-job job num-cols)
+  (cut-to-size num-cols
+    (string-append
+     (fill-up-string 
+      20 (job-name->string (job-name job)))
+     " "
+     (format-job-run-state job)
+     " "
+     (short-date (job-start-time job))
+     " " 
+     (if (job-end-time job)
+	 (short-date (job-end-time job))
+	 (fill-up-string 12 "-"))
+     " "
+     (fill-up-string 
+      6 (if (job-end-time job)
+	    (number->string (job-status job))
+	    "-")))))
+
+(define (make-joblist-headline num-cols)
+  (cut-to-size 
+   num-cols
+   (string-append
+    (fill-up-string 20 "NAME")
+    " "
+    (fill-up-string 12 "RUN STATUS")
+    " "
+    (fill-up-string 10 "START")
+    " "
+    (fill-up-string 10 "END")
+    " "
+    (fill-up-string 6 "STATUS"))))
+
+(define (make-joblist-viewer jobs buffer)
+  (let* ((jobs jobs)
+	 (num-cols (- (result-buffer-num-cols buffer) 1))
+	 (headline (make-joblist-headline num-cols))
+	 (select-list
+	  (make-select-list
+	   (map (lambda (job)
+		  (make-unmarked-element 
+		   job #t (format-job job num-cols)))
+		jobs)
+	   (- (result-buffer-num-lines buffer) 1))))
+
+    (define get-focus-object
+      (make-get-focus-object-method select-list))
+
+    (define (get-selection self for-scheme-mode? focus-object-table)
+      (if for-scheme-mode?
+	  (send self 'get-focus-object focus-object-table)
+	  (let ((marked (select-list-get-selection select-list)))
+	    (if (null? marked)
+		(number->string 
+		 (proc:pid (job-proc (select-list-selected-entry select-list))))
+		(string-join (map (lambda (job)
+				    (number->string
+				     (proc:pid (job-proc job))))
+				  marked))))))
+
+    (lambda (message)
+
+      (case message
+
+	((paint)
+	 (lambda (self win buffer have-focus?)
+	   (mvwaddstr win 0 0 headline)
+	   (paint-selection-list-at 
+	    select-list 0 1 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 "joblist-viewer unknown message" message))))))
+
+(define (list-of-jobs? thing)
+  (and (proper-list? thing) (every job? thing)))
+
+(register-plugin!
+ (make-view-plugin make-joblist-viewer list-of-jobs?))
diff --git a/scheme/job.scm b/scheme/job.scm
index ad58b03..99a0722 100644
--- a/scheme/job.scm
+++ b/scheme/job.scm
@@ -1,19 +1,26 @@
 (define-record-type job :job
-  (really-make-job name pty-in pty-out proc status)
+  (really-make-job name pty-in pty-out proc 
+		   status
+		   start-time end-time
+		   run-status)
   job?
   (name job-name)
   (pty-in job-pty-in)
   (pty-out job-pty-out)
   (proc job-proc)
-  (status really-job-status))
+  (status really-job-status)
+  (start-time job-start-time)
+  (end-time job-end-time set-job-end-time!)
+  (run-status job-run-status set-job-run-status!))
 
 (define-record-discloser :job
   (lambda (r)
-    `(job ,(job-name r))))
+    `(job ,(job-name r) ,(job-run-status r))))
 
 (define (make-job name pty-in pty-out proc)
-  (let ((job (really-make-job name pty-in pty-out proc
-			      (make-placeholder))))
+  (let ((job (really-make-job 
+	      name pty-in pty-out proc (make-placeholder)
+	      (date) #f 'running)))
     (spawn-job-status-surveillant job)
     (add-job! job)
     job))
@@ -28,8 +35,23 @@
   (let ((channel (make-channel)))
     (spawn
      (lambda ()
-       (placeholder-set! 
-	(really-job-status job) (wait (job-proc job)))))))
+       (let ((status (wait (job-proc job))))
+	 (set-job-end-time! job (date))
+	 (set-job-run-status! job 'ready)
+	 (placeholder-set! 
+	  (really-job-status job) status))))))
+
+(define (job-running? job)
+  (eq? (job-run-status job) 'running))
+
+(define (job-ready? job)
+  (eq? (job-run-status job) 'ready))
+
+(define (job-waiting-for-input? job)
+  (eq? (job-run-status job) 'waiting-for-input))
+
+(define (job-has-new-output? job)
+  (eq? (job-run-status job) 'new-output))
 
 (define (signal-job signal job)
   (signal-process-group signal (job-proc job)))
@@ -143,3 +165,5 @@
 	      (exec-epf epf))))
        (lambda (proc pty-in pty-out tty-name)
 	 (make-job (quote epf) pty-in pty-out proc))))))
+
+;;; EOF
diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm
index 16ea7c0..f449681 100644
--- a/scheme/nuit-engine.scm
+++ b/scheme/nuit-engine.scm
@@ -292,7 +292,9 @@
 
 (define (paste-selection/refresh viewer)
   (add-string-to-command-buffer
-   (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?)))
+   (send (current-viewer) 
+	 'get-selection 
+	 (command-buffer-in-scheme-mode?) (focus-table)))
   (print-command-buffer (app-window-curses-win command-window)
 			command-buffer)
   (move-cursor command-buffer result-buffer)
@@ -301,7 +303,10 @@
 (define (paste-focus-object/refresh viewer)
   (add-string-to-command-buffer
    (if (command-buffer-in-command-mode?)
-       (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?))
+       (send (current-viewer) 
+	     'get-selection 
+	     (command-buffer-in-scheme-mode?)
+	     (focus-table))
        (send (current-viewer) 'get-focus-object (focus-table))))
   (print-command-buffer (app-window-curses-win command-window)
 			command-buffer)
diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm
index 8c59eec..ab01bbd 100644
--- a/scheme/nuit-packages.scm
+++ b/scheme/nuit-packages.scm
@@ -138,6 +138,7 @@
 	srfi-1
 	srfi-13
         
+	joblist
         fs-object
 	pps
 	nuit-eval
@@ -196,20 +197,43 @@
 	  select-list-selected-entry
 
 	  select-list-navigation-key?
-	  select-list-marking-key?))
+	  select-list-marking-key?
+
+	  make-get-focus-object-method))
 
 (define-structure select-list select-list-interface
   (open scheme
 	srfi-1
+	(subset srfi-13 (string-join))
 	define-record-types
 	signals
-	
+
+	(subset focus-table (make-focus-object-reference))
 	tty-debug
 	plugin
 	layout
 	ncurses)
   (files select-list))
 
+;;; joblist viewer
+
+(define-structure joblist-viewer
+    (export)
+  (open scheme-with-scsh
+	srfi-1
+	srfi-6
+	(subset srfi-13 (string-join))
+	signals
+	
+	objects
+	jobs
+	ncurses
+	focus-table
+	select-list
+	plugin
+	layout)
+  (files job-viewer))
+
 ;;; inspector
 
 (define-interface nuit-inspector-interface
@@ -336,6 +360,17 @@
   (export make-job
 	  job-status
 	  job-status-rv
+
+	  job?
+	  job-running?
+	  job-ready?
+	  job-waiting-for-input?
+	  job-has-new-output?
+	  job-start-time
+	  job-end-time
+	  job-proc
+	  job-name
+
 	  signal-job
 	  stop-job
 	  continue-job
@@ -409,6 +444,7 @@
 	jobs
 	joblist
 	;; the following modules are plugins
+	joblist-viewer
 	dirlist-view-plugin
         user-group-info-plugin
 	process-viewer
diff --git a/scheme/process.scm b/scheme/process.scm
index c70a22e..56e9732 100644
--- a/scheme/process.scm
+++ b/scheme/process.scm
@@ -48,7 +48,7 @@
           processes))
 	(header (make-header-line (result-buffer-num-cols buffer))))
 
-    (define (get-selection self for-scheme-mode?)
+    (define (get-selection self for-scheme-mode? focus-object-table)
       (let ((marked (select-list-get-selection select-list)))
 	(if (null? marked)
 	    (number->string 
@@ -57,19 +57,6 @@
 	    (string-append
 	     "'"(exp->string (map process-info-pid marked))))))
 
-    (define (get-focus-object self focus-object-table)
-      (let ((marked (select-list-get-selection select-list))
-	    (make-reference (lambda (obj)
-			      (make-focus-object-reference 
-			       focus-object-table obj))))
-	(if (null? marked)
-	      (exp->string 
-	       (make-reference (select-list-selected-entry select-list)))
-	      (string-append
-	       "(list " 
-	       (string-join (map exp->string (map make-reference marked)))
-	       ")"))))
-
     (lambda (message)
 
       (case message
@@ -88,7 +75,8 @@
 
        ((get-selection) get-selection)	
 
-       ((get-focus-object) get-focus-object)
+       ((get-focus-object) 
+	(make-get-focus-object-method select-list))
        
        (else 
 	(error "pps-viewer unknown message" message))))))
diff --git a/scheme/select-list.scm b/scheme/select-list.scm
index 3dd4ff6..1b12e53 100644
--- a/scheme/select-list.scm
+++ b/scheme/select-list.scm
@@ -173,4 +173,19 @@
 (define (select-list-selected-entry select-list)
   (element-value
    (list-ref (select-list-elements select-list)
-	     (select-list-cursor-index select-list))))
\ No newline at end of file
+	     (select-list-cursor-index select-list))))
+
+(define (make-get-focus-object-method select-list)
+  (lambda (self focus-object-table)
+    (let ((marked (select-list-get-selection select-list))
+	  (make-reference (lambda (obj)
+			    (make-focus-object-reference 
+			     focus-object-table obj))))
+      (if (null? marked)
+	  (exp->string 
+	   (make-reference (select-list-selected-entry select-list)))
+	  (string-append
+	   "(list " 
+	   (string-join (map exp->string (map make-reference marked)))
+	   ")")))))
+
diff --git a/scheme/std-command.scm b/scheme/std-command.scm
index 2e78438..10b4b91 100644
--- a/scheme/std-command.scm
+++ b/scheme/std-command.scm
@@ -139,6 +139,17 @@
  (make-command-plugin "exit"
                       no-completer
                       (lambda (command args)
+			(clear)
                         (exit (if (null? args)
                                   0
-                                  (string->number (car args)))))))
\ No newline at end of file
+                                  (string->number (car args)))))))
+
+(register-plugin!
+ (make-command-plugin "jobs"
+		      no-completer
+		      (lambda (command args)
+			(append 
+			 (running-jobs) (ready-jobs)
+			 (jobs-with-new-output) 
+			 (jobs-waiting-for-input)))))
+