ADDED   gutils.scm
Index: gutils.scm
==================================================================
--- /dev/null
+++ gutils.scm
@@ -0,0 +1,42 @@
+;;======================================================================
+;; Copyright 2006-2012, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+(require-library iup)
+(import (prefix iup iup:))
+(use canvas-draw)
+
+(use srfi-1 regex regex-case srfi-69)
+(declare (unit gutils))
+
+(define (gutils:colors-similar? color1 color2)
+  (let* ((c1 (map string->number (string-split color1)))
+	 (c2 (map string->number (string-split color2)))
+	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
+    (null? (filter (lambda (x)(> x 3)) delta))))
+
+(define (gutils:get-color-for-state-status state status)
+  (case (string->symbol state)
+    ((COMPLETED)
+     (if (equal? status "PASS")
+	 "70 249 73"
+	 (if (or (equal? status "WARN")
+		 (equal? status "WAIVED"))
+	     "255 172 13"
+	     "223 33 49"))) ;; greenish orangeish redish
+    ((LAUNCHED)         "101 123 142")
+    ((CHECK)            "255 100 50")
+    ((REMOTEHOSTSTART)  "50 130 195")
+    ((RUNNING)          "9 131 232")
+    ((KILLREQ)          "39 82 206")
+    ((KILLED)           "234 101 17")
+    ((NOT_STARTED)      "240 240 240")
+    (else               "192 192 192")))
+

ADDED   newdashboard.scm
Index: newdashboard.scm
==================================================================
--- /dev/null
+++ newdashboard.scm
@@ -0,0 +1,395 @@
+;;======================================================================
+;; Copyright 2006-2012, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+(use format)
+(require-library iup)
+(import (prefix iup iup:))
+(use canvas-draw)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (uses margs))
+(declare (uses launch))
+(declare (uses megatest-version))
+(declare (uses gutils))
+(declare (uses db))
+(declare (uses server))
+(declare (uses synchash))
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+(define help (conc 
+"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+  version " megatest-version "
+  license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+  -h                : this help
+  -server host:port : connect to host:port instead of db access
+  -test testid      : control test identified by testid
+  -guimonitor       : control panel for runs
+
+Misc
+  -rows N         : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args 
+		 (argv)
+		 (list  "-rows"
+			"-run"
+			"-test"
+			"-debug"
+			"-host" 
+			) 
+		 (list  "-h"
+			"-guimonitor"
+			"-main"
+			"-v"
+			"-q"
+		       )
+		 args:arg-hash
+		 0))
+
+(if (args:get-arg "-h")
+    (begin
+      (print help)
+      (exit)))
+
+(if (not (setup-for-run))
+    (begin
+      (print "Failed to find megatest.config, exiting") 
+      (exit 1)))
+
+(if (args:get-arg "-host")
+    (begin
+      (set! *runremote* (string-split (args:get-arg "-host" ":")))
+      (client:launch))
+    (client:launch))
+
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define (message-window msg)
+  (iup:show
+   (iup:dialog
+    (iup:vbox 
+     (iup:label msg #:margin "40x40")))))
+
+(define (iuplistbox-fill-list lb items . default)
+  (let ((i 1)
+	(selected-item (if (null? default) #f (car default))))
+    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+    (for-each (lambda (item)
+		(iup:attribute-set! lb (number->string i) item)
+		(if selected-item
+		    (if (equal? selected-item item)
+			(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
+		(set! i (+ i 1)))
+	      items)
+    i))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+  (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+  (hash-table-set! *searchpatts* x val))
+
+(define (main-menu)
+  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
+   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
+		       (iup:menu-item "Open"  action: (lambda (obj)
+							(show (iup:file-dialog))
+							(print "File->open " obj)))
+		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
+		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
+   (iup:menu-item "Tools" (iup:menu
+		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
+		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
+		       ;;  					   (show message-window
+		       ;;  					     #:modal? #t
+		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
+		       ;;  					     ;; #:x 'mouse
+		       ;;  					     ;; #:y 'mouse
+		       ;;  )					     
+		       ))))
+
+
+
+(define (mtest)
+  (let* ((curr-row-num     0)
+	 (rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string))
+	 (keys-matrix      (iup:matrix
+		            #:expand "VERTICAL"
+		            ;; #:scrollbar "YES"
+		            #:numcol 1
+		            #:numlin 20
+		            #:numcol-visible 1
+		            #:numlin-visible 5
+		            #:click-cb (lambda (obj lin col status)
+					 (print "obj: " obj " lin: " lin " col: " col " status: " status))))
+	 (setup-matrix     (iup:matrix
+		            #:expand "YES"
+		            #:numcol 1
+		            #:numlin 5
+		            #:numcol-visible 1
+		            #:numlin-visible 3))
+	 (jobtools-matrix  (iup:matrix
+			    #:expand "YES"
+			    #:numcol 1
+			    #:numlin 5
+			    #:numcol-visible 1
+			    #:numlin-visible 3))
+	 (validvals-matrix (iup:matrix
+			    #:expand "YES"
+			    #:numcol 1
+			    #:numlin 2
+			    #:numcol-visible 1
+			    #:numlin-visible 2))
+	 (envovrd-matrix   (iup:matrix
+			    #:expand "YES"
+			    #:numcol 1
+			    #:numlin 20
+			    #:numcol-visible 1
+			    #:numlin-visible 8))
+	 (disks-matrix     (iup:matrix
+			    #:expand "YES"
+			    #:numcol 1
+			    #:numlin 20
+			    #:numcol-visible 1
+			    #:numlin-visible 8))
+	 )
+    (iup:attribute-set! keys-matrix "0:0" "Field Num")
+    (iup:attribute-set! keys-matrix "0:1" "Field Name")
+    (iup:attribute-set! keys-matrix "WIDTH1" "100")
+    (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+    (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+    (iup:attribute-set! disks-matrix "WIDTH1" "120")
+    (iup:attribute-set! disks-matrix "WIDTH0" "100")
+    (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+    (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+    (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+    ;; fill in keys
+    (set! curr-row-num 1)
+    (for-each 
+     (lambda (var)
+       (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
+       (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
+       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
+     (configf:section-vars rawconfig "fields"))
+
+    ;; fill in existing info
+    (for-each 
+     (lambda (mat fname)
+       (set! curr-row-num 1)
+       (for-each
+	(lambda (var)
+	  (iup:attribute-set! mat (conc curr-row-num ":0") var)
+	  (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+	  (set! curr-row-num (+ curr-row-num 1)))
+	(configf:section-vars rawconfig fname)))
+     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+     (list "setup"      "jobtools"      "validvalues"      "env-override" "disks"))
+
+    (for-each
+     (lambda (mat)
+       (iup:attribute-set! mat "0:1" "Value")
+       (iup:attribute-set! mat "0:0" "Var")
+       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+       (iup:attribute-set! mat "FIXTOTEXT" "C1")
+       (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+       (iup:attribute-set! mat "WIDTH1" "120")
+       (iup:attribute-set! mat "WIDTH0" "100")
+       )
+     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
+
+    (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+    (iup:attribute-set! envovrd-matrix   "WIDTH1" "290")
+
+    (iup:vbox
+     (iup:hbox
+       
+      (iup:vbox
+       (let ((tabs (iup:tabs 
+		    ;; The required tab
+		    (iup:hbox
+		     ;; The keys
+		     (iup:frame 
+		      #:title "Keys (required)"
+		      (iup:vbox
+		       (iup:label (conc "Set the fields for organising your runs\n"
+					"here. Note: can only be changed before\n"
+					"running the first run when megatest.db\n"
+					"is created."))
+		       keys-matrix))
+		     (iup:vbox
+		      ;; The setup section
+		      (iup:frame
+		       #:title "Setup"
+		       (iup:vbox
+			(iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
+					 "linktree : directory where linktree will be created."))
+			setup-matrix))
+		      ;; The jobtools
+		      (iup:frame
+		       #:title "Jobtools"
+		       (iup:vbox 
+			(iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
+					 "useshell : use system to run your launcher\n"
+					 "workhosts : spread jobs out on these hosts"))
+			jobtools-matrix))
+		      ;; The disks
+		      (iup:frame
+		       #:title "Disks"
+		       (iup:vbox
+			(iup:label (conc "Enter names and existing paths of locations to run tests")) 
+			disks-matrix))))
+		    ;; The optional tab
+		    (iup:vbox
+		     ;; The Environment Overrides
+		     (iup:frame 
+		      #:title "Env override"
+		      envovrd-matrix)
+		     ;; The valid values
+		     (iup:frame
+		      #:title "Validvalues"
+		      validvals-matrix)
+		     ))))
+	 (iup:attribute-set! tabs "TABTITLE0" "Required settings")
+	 (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
+	 tabs))
+       ))))
+
+(define (rconfig)
+  (iup:vbox
+   (iup:frame #:title "Default")))
+
+(define (tests)
+  (iup:hbox 
+   (iup:frame #:title "Tests browser")))
+
+(define (runs)
+  (let* ((runs-matrix     (iup:matrix
+			   #:expand "YES"
+			   ;; #:fittosize "YES"
+			   #:scrollbar "YES"
+			   #:numcol 100
+			   #:numlin 100
+			   #:numcol-visible 7
+			   #:numlin-visible 7
+			   #:click-cb (lambda (obj lin col status)
+					(print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+;;     (iup:attribute-set! keys-matrix "0:0" "Field Num")
+;;     (iup:attribute-set! keys-matrix "0:1" "Field Name")
+;;     (iup:attribute-set! keys-matrix "WIDTH1" "100")
+;;     (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+;;     (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+;;     (iup:attribute-set! disks-matrix "WIDTH1" "120")
+;;     (iup:attribute-set! disks-matrix "WIDTH0" "100")
+;;     (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+;;     (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+;;     (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+    ;; fill in keys
+;;     (set! curr-row-num 1)
+;;     (for-each 
+;;      (lambda (var)
+;;        (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
+;;        (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
+;;        (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
+;;      (configf:section-vars rawconfig "fields"))
+
+    ;; fill in existing info
+;;    (for-each 
+;;     (lambda (mat fname)
+;;       (set! curr-row-num 1)
+;;       (for-each
+;;	(lambda (var)
+;;	  (iup:attribute-set! mat (conc curr-row-num ":0") var)
+;;	  (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+;;	  (set! curr-row-num (+ curr-row-num 1)))
+;;	(configf:section-vars rawconfig fname)))
+;;     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+;;     (list "setup"      "jobtools"      "validvalues"      "env-override" "disks"))
+
+    (for-each
+     (lambda (mat)
+       (iup:attribute-set! mat "0:1" "ubuntu\nnfs\nnone")
+       (iup:attribute-set! mat "0:0" "Test")
+       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+       ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
+       (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+       (iup:attribute-set! mat "WIDTH1" "120")
+       (iup:attribute-set! mat "WIDTH0" "100")
+       )
+     (list runs-matrix))
+
+;;    (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+;;    (iup:attribute-set! envovrd-matrix   "WIDTH1" "290")
+    
+    (iup:hbox
+     (iup:frame 
+      #:title "Runs browser"
+      (iup:vbox
+       runs-matrix)))))
+
+(define (main-panel)
+  (iup:dialog
+   #:title "Menu Test"
+   #:menu (main-menu)
+   (let ((tabtop (iup:tabs 
+		  (runs)
+		  (mtest) 
+		  (rconfig)
+		  (tests)
+		  )))
+     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
+     (iup:attribute-set! tabtop "TABTITLE3" "Tests")
+     (iup:attribute-set! tabtop "TABTITLE1" "megatest.config") 
+     (iup:attribute-set! tabtop "TABTITLE2" "runconfigs.config")
+     tabtop)))
+
+;;======================================================================
+;; Process runs
+;;======================================================================
+
+;; TO-DO
+;;  1. Make "data" hash-table hierarchial store of all displayed data
+;;  2. Update synchash to understand "get-runs", "get-tests" etc.
+;;  3. Add extraction of filters to synchash calls
+;;
+(define (run-update data filters)
+  (synchash:client-get db:get-runs  "get-runs"  data filters)
+  (synchash:client-get db:get-tests "get-tests" data filters))
+
+(define (newdashboard)
+  (let* ((data    (make-hash-table))
+	 (filters (make-hash-table))
+	 (keys    (cdb:remote-run db:get-keys #f))
+	 (keyvals (map (lambda (k)(list (vector-ref k 0) "%")) keys)))
+    (iup:show (main-panel))
+    ;; (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
+    (iup:callback-set! *tim*
+		       "ACTION_CB"
+		       (lambda (x)
+			 (run-update rundata keyvals)))))
+
+(newdashboard)    
+(iup:main-loop)

ADDED   synchash.scm
Index: synchash.scm
==================================================================
--- /dev/null
+++ synchash.scm
@@ -0,0 +1,88 @@
+;;======================================================================
+;; Copyright 2006-2012, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+;;======================================================================
+;; A hash of hashes that can be kept in sync by sending minial deltas
+;;======================================================================
+
+(use format)
+(use srfi-1 srfi-69)
+
+(declare (unit synchash))
+(declare (uses db))
+(declare (uses server))
+(include "db_records.scm")
+
+(define (synchash:make)
+   (make-hash-table))
+
+;; given an alist of objects '((id obj) ...) 
+;;   1. remove unchanged objects from the list
+;;   2. create a list of removed objects by id
+;;   3. remove removed objects from synchash
+;;   4. replace or add new or changed objects to synchash
+;;
+(define (synchash:get-delta indat synchash)
+  (let ((deleted '())
+	(changed '())
+	(found   '())
+	(orig-keys (hash-table-keys synchash)))
+    (for-each
+     (lambda (item)
+       (let* ((id  (car  item))
+	      (dat (cadr item))
+	      (ref (hash-table-ref/default synchash id #f)))
+	 (if (not (equal? dat ref)) ;; item changed or new
+	     (begin
+	       (set! changed (cons item changed))
+	       (hash-table-set! synchash id dat)))
+	 (set! found (cons id found))))
+     indat)
+    (for-each 
+     (lambda (id)
+       (if (not (member id found))
+	   (begin
+	     (set! deleted (cons id deleted))
+	     (hash-table-delete! synchash id))))
+     orig-keys)
+    (list changed deleted)))
+    
+;; (cdb:remote-run db:get-keys #f)  
+;; (cdb:remote-run db:get-num-runs #f "%")
+;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts)
+(define (synchash:client-get proc synckey keynum synchash . params)
+  (let* ((data   (apply cdb:remote-run synchash:server-get #f proc synckey params))
+	 (newdat (car data))
+	 (removs (cadr data)))
+    (for-each 
+     (lambda (item)
+       (let ((id  (car item))
+	     (dat (cadr item)))
+	 (hash-table-set! synchash id dat)))
+     newdat)
+    (for-each
+     (lambda (id)
+       (hash-table-delete! synchash id))
+     removs)
+    synchash))
+
+
+(define *synchashes* (make-hash-table))
+
+(define (synchash:server-get db proc synckey keynum . params)
+  (let* ((synchash (hash-table-ref/default *synchashes* synckey #f))
+	 (newdat   (apply proc db params)))
+    (if (not synchash)
+	(begin
+	  (set! synchash (make-hash-table))
+	  (hash-table-set! *synchashes* synckey synchash)))
+    (synchash:get-delta newdat synchash)))
+